home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
rbbs_pc
/
rbbsbas.zip
/
RBBSSUB4.BAS
< prev
next >
Wrap
BASIC Source File
|
1988-10-02
|
119KB
|
3,083 lines
' $linesize:132
' $title: 'RBBSSUB4.BAS CPC17-1A, Copyright 1986 - 88 by D. Thomas Mack'
' Copyright 1988 by D. Thomas Mack, all rights reserved.
' Name ...............: RBBSSUB4.BAS
' Written by .........: D. Thomas Mack
' First Released .....: September 18, 1988
' Subsequent Releases.:
' Copyright ..........: 1986, 1987, 1988
' Purpose.............: The Remote Bulletin Board System for the IBM PC,
' RBBS-PC.BAS utilizes a lot of common subroutines.
' Those that do not require error trapping are
' incorporated within RBBSSUB2.BAS, RBBSSUB3.BAS,
' RBBSSUB4.BAS and RBBSSUB5.BAS as separately
' callable subroutines in order to free up as much
' code as possible within the 64K code segment
' used by RBBS-PC.BAS.
' Parameters..........: Most parameters are passed via a COMMON statement.
'
' Subroutine Line Function of Subroutine
' Name Number
' ANYBUT 59760 Determine where a "word" begins
' ASKUSERS 64005 Ask users questions based on a script and save answers
' ASKMORE 59854 Check whether screen full
' AUTOPAGE Check whether to notify sysop caller is on
' BADFILECHAR 59800 Check file name for bad character
' BRACKET 59950 Puts strings around a substring
' BUFFILE 58400 Write a file to the user quickly
' BUFSTRNG 58300 Write a string with imbedded CR/LF to the user quickly
' CHKCOLOR 59900+ Highlighting based on search string
' CHKNARY 58190 Check for the occurance of a string in an array
' COLORDIR 59920 Adds colorization to FMS directory entry
' COLORPMT 59924+ Colorizes prompts
' COMPDATE 59200+ Produces a computational data from YY, MM, DD
' CONFMAIL 59854 Check conference mail waiting
' CONVDIRS 58950 Checks for U & A (shorthand) and converts appropriately
' CSTRDATE 59200 Compress date in string format to 2 characters
' EOFCOMM 60000 Determine whether any chars in comm port buffer
' EXPDATE 59854+ Calculate registration expiration date
' FAKEXRPT 62650 Write out file transfer report for protocols that don't
' FINDEND 58770 Find where a "word" ends
' FINDFILE 58790 Determine whether a file exists without opening it
' FMS 58200 Search the upload management system for entries
' GETALL 59780 Get list of all directories to display
' GETDIRS 58900 Prompts for directories for file list/new/search cmds
' GETMATTR 62530 Restore attributes of original message
' GETYMD 59200 Pulls YY, MM, or DD from a 2 byte stored date
' GSANDR 60100 Global search and replace
' LOGDOWN 59400 Records download in private directory
' MARKTIME 60200 Give visual feedback during lengthy process
' METAGSR 60102+ Meta statement global search and replace
' MIMPORT 59700 Allow local user to import a text file to a message
' MUZAK 59100 Play musical themes for different RBBS functions
' PERSFILE 59300 View and select personal files for downloading
' PROTOCOL 62600 Determine if external protocols are available
' PUTMATTR 62520 Save attributes of original message
' REMOVE 58210 Remove characters from within strings
' ROTORSDIR 58700 Searches for a file using list of subdirs
' RPTTIME 62530+ Report date/time and time on
' SETABORT 58750 Set time for a process to abort
' SETECHO 59600 Set RBBS properly for who is to echo
' SETHILITE 59900+ Set user preference on highlighting
' SMARTTXT 58250 Process SMART TEXT control strings
' SUBMENU 59500 Processes options that have sub-menus
' TIMEDOUT 63000 Write timed exit semaphore file
' TIMELOCK 60150 Check for TIME LOCK on certain features
' TRANSFER 62620 RBBS-PC support for external protocols for file transfer
' TOGGLE 57000 Toggles or views user options
' TWOBYTEDATE 59200 Reduces a data to 2 byte string for space compression
' USERCOLOR 59970 Lets user set color for text and whether bold
' USERFACE 59450 Processes programmable user interface
' VIEWARC 64600 Display .ARC file contents to user
' XFRETURN 62629 Private door exit routine
' WIPELINE 58800 Wipes away a line so next prints in its place
' WORDWRAP 59700+ Adjust a message --wrap linesand perserve paragraphs
'
' $INCLUDE: 'RBBS-VAR.BAS'
'
' $SUBTITLE: 'TOGGLE - Toggle User Preferences'
' $PAGE
'
' SUBROUTINE NAME -- TOGGLE
'
' INPUT PARAMETERS -- TOGGLE.OPTION Option to toggle or view
' according to the following:
' TOGGLE.OPTION PREFERENCE
' TOGGLE VIEW
' 1 -1 Autodownload
' 2 -2 Bulletin review on logon
' 3 -3 Case change
' 4 -4 File review on logon
' 5 -5 Highlight
' 6 -6 Line feeds
' 7 -7 Nulls
' 8 -8 TurboKey
' 9 -9 Expert
' 10 -10 Bell
'
' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER passed from TPUT
'
' SUBROUTINE PURPOSE -- Sets or views any single user preference value
'
SUB TOGGLE (TOGGLE.OPTION) STATIC
57000 SUBROUTINE.PARAMETER = 0
IF TOGGLE.OPTION < 0 THEN _
GOTO 57005
ON TOGGLE.OPTION GOSUB _
57010, _ 'Autodownload
57120, _ 'Bulletin review on logon
57260, _ 'Case change
57150, _ 'File review on logon
57040, _ 'Highlight
57100, _ 'Line feeds
57210, _ 'Nulls
57230, _ 'TurboKey
57190, _ 'Expert
57170 'Bell
EXIT SUB
57005 CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
ON -TOGGLE.OPTION GOSUB _
57030, _ 'Autodownload
57130, _ 'Bulletin review on logon
57270, _ 'Case change
57160, _ 'File review on logon
57050, _ 'Highlight
57110, _ 'Line feeds
57220, _ 'Nulls
57240, _ 'TurboKey
57200, _ 'Expert
57180 'Bell
EXIT SUB
57010 IF AUTODOWNLOAD.DESIRED THEN _
GOTO 57020
IF NOT AUTODOWNLOAD.VERIFIED THEN _
CALL TESTUSER
IF NOT AUTODOWNLOAD.AVAILABLE THEN _
CALL QTPUT ("Your comm pgm does not support AUTODOWNLOAD",1) : _
AUTODOWNLOAD.DESIRED = TRUE
57020 AUTODOWNLOAD.DESIRED = NOT AUTODOWNLOAD.DESIRED
57030 A$ = "Autodownload " + FNOFFON$(AUTODOWNLOAD.DESIRED)
CALL QTPUT (A$,1)
RETURN
57040 IF EMPHASIZE.ON.DEF$ = "" THEN _
CALL QTPUT ("Highlighting unavailable",1) : _
RETURN
CALL SETHILITE (NOT HIGHLIGHT.OFF)
IF HIGHLIGHT.OFF THEN _
CALL QTPUT (COLOR.RESET$,0)
GOSUB 57050
CALL USERCOLOR
RETURN
57050 IF EMPHASIZE.ON$ <> "" THEN _
EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
CALL QTPUT (EMPHASIZE.ON$ + "Highlighting" + EMPHASIZE.OFF$ + _
" " + FNOFFON$(NOT HIGHLIGHT.OFF),1)
RETURN
57100 LINE.FEEDS = NOT LINE.FEEDS
IF LOCAL.USER THEN _
LINE.FEEDS = TRUE
57110 CALL QTPUT("Line Feeds " + FNOFFON$(LINE.FEEDS),1)
CALL SETCRLF
RETURN
57120 CHECK.BULLETIN.LOGON = NOT CHECK.BULLETIN.LOGON
57130 A$ = MID$("SKIP CHECK",1 -5 * CHECK.BULLETIN.LOGON,5) + _
" old BULLETINS in logon"
CALL QTPUT (A$,1)
RETURN
57150 SKIP.FILES.LOGON = NOT SKIP.FILES.LOGON
57160 A$ = MID$("CHECKSKIP",1 -5 * SKIP.FILES.LOGON,5) + _
" new files in logon"
CALL QTPUT (A$,1)
RETURN
57170 PROMPT.BELL = NOT PROMPT.BELL
57180 A$ = "Prompt Bell " + FNOFFON$(PROMPT.BELL)
CALL QTPUT (A$,1)
RETURN
57190 EXPERT.USER = NOT EXPERT.USER
CALL SETEXPERT
57200 A$ = MID$("NoviceExpert",1 -6 * EXPERT.USER,6)
CALL QTPUT (A$,1)
RETURN
57210 NULLS = NOT NULLS
NUL$ = MID$(STRING$(5,0),1, - 5 * NULLS)
CALL SETCRLF
57220 A$ = "Nulls " + FNOFFON$(NULLS)
CALL QTPUT (A$,1)
RETURN
57230 TURBO.KEY.USER = NOT TURBO.KEY.USER
57240 CALL QTPUT ("TurboKey " + FNOFFON$(TURBO.KEY.USER),1)
RETURN
57260 UPPER.CASE = NOT UPPER.CASE
57270 A$ = "UPPER CASE " + _
MID$("and lowerONLY",1 - 9 * UPPER.CASE,9)
CALL QTPUT (A$,1)
57280 USE.TPUT = (UPPER.CASE OR XON.XOFF)
RETURN
END SUB
'
' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array'
' $PAGE
'
' SUBROUTINE NAME -- CHKNARY
'
' INPUT PARAMETERS -- PARAMETER MEANING
' ELEMENT$ THE STRING TO CHECK FOR
' ARRAY$() THE ARRAY TO BE SEARCHED
' NUM.ENTRIES.TO.SEARCH NUMBER OF ENTRIES WITHIN IN
' THE ARRAY TO BE SEARCHED
'
' OUTPUT PARAMETERS -- IS.IN.ARA 0 = STRING NOT FOUND IN THE
' ARRAY SPECIFIED
' OTHERWISE IT IS THE NUMBER OF
' ELEMENT WITHIN THE ARRAY THAT
' WAS FOUND TO MATCH
'
' SUBROUTINE PURPOSE -- SEARCH AN ARRAY FOR A SPECIFIED STRING AND, IF FOUND,
' RETURN THE NUMBER OF THE ELEMENT THAT MATCHED.
'
SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC
58190 IS.IN.ARA = 1
CALL ALLCAPS (ELEMENT$)
MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1
ARRAY$(MAX.TRIES) = ELEMENT$
WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$
IS.IN.ARA = IS.IN.ARA + 1
WEND
IF IS.IN.ARA = MAX.TRIES THEN _
IS.IN.ARA = 0
END SUB
' $SUBTITLE: 'FMS - subroutine to search the upload management system'
' $PAGE
'
' SUBROUTINE NAME -- FMS
'
' INPUT PARAMETERS -- PARAMETER MEANING
' DIR.TO.SEARCH$ RBBS-PC "DIR" CATEGORY TO LOOK
' FOR
' SEARCH.STRING$ STRING TO SEARCH FOR
' SEARCH.DATE$ DATE TO SEARCH FOR
' CATEGORY.NAME$()
' CATEGORY.CODE$()
' CATEGORY.DESC$()
' CAT.FOUND
' NUM.CATEGORIES
'
' OUTPUT PARAMETERS -- PROCESSED.IN.FMS
' DOWNLOAD.FLAG
'
' SUBROUTINE PURPOSE -- TO SEARCH THE UPLOAD MANAGMENT SYSTEM AND DISPLAY THE
' FILES BEING SEARCHED FOR AS WELL AS THE CATEGORY DE-
' SCRIPTIONS
'
SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$, _
PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1), _
CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND,ABORT.INDEX) STATIC
58200 DOWNLOAD.FLAG = 0
CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND)
PROCESSED.IN.FMS = PROCESSED.IN.FMS OR (CAT.FOUND > 0)
IF PROCESSED.IN.FMS THEN _
SUBROUTINE.PARAMETER = 5 : _
GOSUB 58202 : _
A$ = "Scanning directory " + _
DIR.TO.SEARCH$ + _
HDR$ + _
" - " + _
CATEGORY.DESC$(CAT.FOUND) : _
CALL TPUT : _
CAT$ = CATEGORY.CODE$(CAT.FOUND) : _
CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX)
EXIT SUB
58202 A$ = SEARCH.DATE$
IF LEN(A$) > 0 THEN _
A$ = MID$(A$,3) + LEFT$(A$,2)
HDR$ = " for " + _
SEARCH.STRING$ + _
A$
IF LEN(HDR$) < 6 THEN _
HDR$ = ""
RETURN
END SUB
' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string'
' $PAGE
'
' SUBROUTINE NAME -- REMOVE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' BADSTRING$ STRING CONTAINING CHARACTERS
' TO BE DELETED FROM "L$"
' L$ STRING TO BE ALTERED
'
' OUTPUT PARAMETERS -- L$ WITH THE CHARACTERS IN
' "BADSTRING#" DELETED FROM IT
'
' SUBROUTINE PURPOSE -- TO REMOVE ALL INSTANCES OF THE CHARACTERS IN
' "BADSTRING$" FROM "L$"
'
SUB REMOVE (L$,BADSTRNG$) STATIC
58210 J = 0
FOR I=1 TO LEN(L$)
IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN _
J = J + 1 : _
MID$(L$,J,1) = MID$(L$,I,1)
NEXT I
L$ = LEFT$(L$,J)
END SUB
'
' $SUBTITLE: 'SMARTTXT - smart text substitution'
' $PAGE
'
' SUBROUTINE NAME -- SMARTTXT (WRITTEN BY DOUG AZZARITO)
'
' INPUT PARAMETERS -- STRNG.WORK$ string to scan for Smart Text
' CR.FOUND Does this line contain a CR?
' SMART.TEXT Smart Text control code
'
' OUTPUT PARAMETERS -- STRNG.WORK$ Input string with Smart replaced
'
' SUBROUTINE PURPOSE -- Smart Text allows control strings in text files
' to be replaced at runtime with user info or other
' data. The Smart Text control code is a 1-byte
' code (configurable) with a 2-byte action code.
'
SUB SMARTTXT (STRNG.WORK$, CR.FOUND) STATIC
58250 IF SMART.CARRY$<>"" THEN _
STRNG.WORK$ = SMART.CARRY$+STRNG.WORK$
INDEX = INSTR(STRNG.WORK$, SMART.TEXT$)
WHILE INDEX > 0 AND INDEX < LEN(STRNG.WORK$)-1
IF INSTR(MID$(STRNG.WORK$, INDEX+1,2)," ") THEN _
SMART.ACT = 0 _
ELSE _
SMART.ACT = INSTR(SMART.TABLE$, MID$(STRNG.WORK$, INDEX+1, 2))
IF SMART.ACT > 0 THEN _
SMART.ACT = (SMART.ACT+2)/3 : _
ON SMART.ACT GOSUB 58260, 58261, 58262, 58263, 58264, 58265, _
58266, 58267, 58268, 58269, 58270, _
58271, 58272, 58273, 58274, 58275, _
58276, 58277, 58278, 58279, 58280, _
58281, 58282, 58283, 58284 : _
STRNG.WORK$ = LEFT$(STRNG.WORK$, INDEX-1) + SMART.HOLD$ + _
MID$(STRNG.WORK$,INDEX+3)
INDEX = INSTR(INDEX+1, STRNG.WORK$, CHR$(SMART.TEXT))
WEND
IF INDEX AND (INDEX > LEN(STRNG.WORK$)-2) AND NOT CR.FOUND THEN _
SMART.CARRY$ = MID$(STRNG.WORK$,INDEX) : _
STRNG.WORK$ = LEFT$(STRNG.WORK$,INDEX-1) : _
ELSE _
SMART.CARRY$ = ""
EXIT SUB
58260 LINES.PRINTED = 0 ' CS (Clear screen line count reset)
SMART.HOLD$ = ""
RETURN
58261 LINES.PRINTED = PAGE.LENGTH ' PB Page Break
IF NON.STOP THEN _ ' force a 1-time pause
ONE.STOP = TRUE : _ ' if NON STOP is on
NON.STOP = FALSE
SMART.HOLD$ = ""
FORCE.KEYBOARD = TRUE
RETURN
58262 NON.STOP = TRUE ' NS Non-stop
SMART.HOLD$ = ""
RETURN
58263 SMART.HOLD$ = FIRST.NAME$ ' FN User's FIRST name
RETURN
58264 SMART.HOLD$ = LAST.NAME$ ' LN User's LAST name
RETURN
58265 SMART.HOLD$ = MID$(STR$(USER.SECURITY.LEVEL),2) ' SL Security level
RETURN
58266 SMART.HOLD$ = DATE$
RETURN
58267 CALL AMORPM
SMART.HOLD$ = TIM$
RETURN
58268 CALL TIMEREMAIN(TIME.REMAINING!) ' TR Time remaining (in mins)
SMART.HOLD$ = MID$(STR$(INT(TIME.REMAINING!)),2)
RETURN
58269 CALL TIMEREMAIN(TIME.REMAINING!) ' TE Time elapsed (mm:ss)
SMART.HOLD$ = MID$(STR$(INT(TCA!/60)),2)+":"+ MID$(STR$((TCA! MOD 60)+100),3)
RETURN
58270 SMART.HOLD$ = MID$(STR$(INT((TIME.LOCK.SET+0.5)/60)),2) ' TL - Time Lock period
SMART.HOLD$ = SMART.HOLD$ + ":"+ MID$(STR$((TIME.LOCK.SET MOD 60)+100),3)
RETURN
58271 SMART.HOLD$ = MID$(STR$(DAYS.IN.REGISTRATION.PERIOD),2)
RETURN ' RP Registration Length
58272 SMART.HOLD$ = MID$(STR$(REG.DAYS.REMAINING),2)
RETURN ' RR Registration Remaining
58273 SMART.HOLD$ = CITY.STATE$ ' CT Users CITY & STATE
RETURN
58274 SMART.HOLD$ = FG.1$ ' C1 Color 1
RETURN
58275 SMART.HOLD$ = FG.2$ ' C2 Color 2
RETURN
58276 SMART.HOLD$ = FG.3$ ' C3 Color 3
RETURN
58277 SMART.HOLD$ = FG.4$ ' C4 Color 4
RETURN
58278 SMART.HOLD$ = EMPHASIZE.OFF$ ' C0 Reset color
RETURN
58279 SMART.HOLD$ = MID$(STR$(INT(DL.TODAY!)),2)
RETURN ' DD files Dnlded TODAY
58280 SMART.HOLD$ = MID$(STR$(INT(BYTES.TODAY!)),2)
RETURN ' BD Bytes Dnlded TODAY
58281 SMART.HOLD$ = MID$(STR$(INT(DLBYTES!)),2)
RETURN ' DB Download Bytes
58282 SMART.HOLD$ = MID$(STR$(INT(ULBYTES!)),2)
RETURN ' UB Upload Bytes
58283 SMART.HOLD$ = MID$(STR$(DOWNLOADS),2) ' DL Number of Dnlds
RETURN
58284 SMART.HOLD$ = MID$(STR$(UPLOADS),2) ' UL Number of Uplds
RETURN
END SUB
'
' $SUBTITLE: 'BUFSTRNG - subroutine to write a string with imbedded CR/LF'
' $PAGE
'
' SUBROUTINE NAME -- BUFSTRNG
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ STRING TO BE WRITTEN OUT
' DATA.SIZE LENGTH OF STRING - # LEFT
' CHARS TO OUTPUT
'
' OUTPUT PARAMETERS -- STRNG$ IS WRITTEN TO THE USER
'
' SUBROUTINE PURPOSE -- TO SEARCH THE STRING, STRNG$, FOR IMBEDDED CARRIAGE
' RETURNS AND LINE FEEDS AND WRITE OUT EACH LINE WITH
' THE APPROPRIATE SUBSTITUTION (CR/LF IF TO THE LOCAL
' SCREEN OR CR/NULLS/LF IF TO THE COMMUNICATIONS PORT).
'
58300 SUB BUFSTRNG (STRNG$,PASSED.DATA.SIZE,ABORT.INDEX) STATIC
L = LEN(STRNG$)
IF PASSED.DATA.SIZE < L THEN _
L = PASSED.DATA.SIZE
IF L < 1 THEN _
EXIT SUB
FF = PAGE.LENGTH - 1
START.BYTE = 1
IF CARRY.OVER THEN _
IF ASC(STRNG$) = 10 THEN _
START.BYTE = 2 : _
CALL SKIPLINE (1)
CARRY.OVER = (MID$(STRNG$,L,1) = CARRIAGE.RETURN$)
L = L + CARRY.OVER
58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$)
IF CRAT > 0 AND CRAT < L THEN _
CR.FOUND = (MID$(STRNG$,CRAT + 1,1) = LINE.FEED$) _
ELSE CR.FOUND = FALSE
EOL.LEN = -2 * CR.FOUND
IF CR.FOUND THEN _
EOD = CRAT _
ELSE EOD = L + 1
NUM.BYTES = EOD - START.BYTE
STRNG.WORK$ = MID$(STRNG$,START.BYTE,NUM.BYTES)
IF NOT DELETE.INVALID THEN _
GOTO 58304
INDEX = INSTR(STRNG.WORK$,"[")
J = LEN(STRNG.WORK$) - 1
WHILE INDEX > 0 AND INDEX < J
IF MID$(STRNG.WORK$,INDEX + 2,1) = "]" THEN _
IF INSTR (INVALID.OPTS$,MID$(STRNG.WORK$,INDEX + 1,1)) THEN _
MID$(STRNG.WORK$,INDEX + 1,1) = "*"
INDEX = INSTR(INDEX + 1,STRNG.WORK$,"[")
WEND
58304 IF SMART.TEXT THEN _
CALL SMARTTXT (STRNG.WORK$, CR.FOUND)
CALL QTPUT (STRNG.WORK$, - (CR.FOUND))
IF RET THEN _
EXIT SUB
IF LINES.PRINTED < FF THEN _
GOTO 58305
CALL CHKTREMAIN (TIME.REMAINING!)
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
IF NON.STOP THEN _
GOTO 58305
CALL ASKMORE ("",TRUE,FALSE,ABORT.INDEX,STOP.INTERRUPTS)
IF NO THEN _
RET = TRUE : _
EXIT SUB
58305 START.BYTE = EOD + EOL.LEN
IF START.BYTE <= L THEN _
GOTO 58301
END SUB
' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user'
' $PAGE
'
' SUBROUTINE NAME -- BUFFILE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILENAME$ NAME OF THE FILE TO WRITE TO
' OUT TO THE USER
'
' OUTPUT PARAMETERS -- NONE FILE IS WRITTEN TO THE USER
'
' SUBROUTINE PURPOSE -- TO DISPLAY A SEQUENTIAL FILE TO THE USER
'
58400 SUB BUFFILE (FILNAME$,ABORT.INDEX) STATIC
CALL FINDIT (FILNAME$)
IF NOT OK THEN _
EXIT SUB
NO = FALSE
CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC,BUFFER.SIZE)
DATA.SIZE = BUFFER.SIZE
FIELD 2, DATA.SIZE AS SEQ.REC$
NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
IF NOT STOP.INTERRUPTS THEN _
IF NOT CONCAT.FILES THEN _
IF NOT NON.STOP THEN _
A$ = "* Ctrl-K(^K) / ^X aborts. ^S suspends ^Q resumes *" : _
SUBROUTINE.PARAMETER = 2 : _
CALL TPUT
TU = 0
58405 TU = TU + 1
IF TU < NUM.RECS THEN _
GET 2,TU _
ELSE IF TU = NUM.RECS THEN _
GET 2,TU : _
X = INSTR(SEQ.REC$,CHR$(26)) : _
IF X = 0 OR X > LEN.LAST.REC THEN _
DATA.SIZE = LEN.LAST.REC _
ELSE DATA.SIZE = X - 1 _
ELSE GOTO 58419
IF LOCAL.USER THEN _
GOTO 58406
CALL EOFCOMM (CHAR%)
IF CHAR% <> -1 THEN _
GOTO 58407 ' comm port input
58406 KEYBOARD.STACK$ = INKEY$
IF KEYBOARD.STACK$ = "" THEN _ ' no keyboard input
CALL BUFSTRNG (SEQ.REC$,DATA.SIZE,ABORT.INDEX) : _
GOTO 58408
58407 A$ = LEFT$(SEQ.REC$,DATA.SIZE) ' process comm/keyboard
SUBROUTINE.PARAMETER = 4
CALL TPUT
58408 IF SUBROUTINE.PARAMETER <> -1 AND NOT RET THEN _
GOTO 58405
58419 CLOSE 2
BYPASS.TIME.CHECK = FALSE
STOP.INTERRUPTS = FALSE
CALL QTPUT (EMPHASIZE.OFF$,0)
END SUB
' $SUBTITLE: 'FINDLAST - subroutine to find last occurence of a string'
' $PAGE
'
' SUBROUTINE NAME -- FINDLAST
'
' INPUT PARAMETERS -- PARAMETER MEANING
' LOOK.IN$ STRING TO LOOK INTO
' LOOK.FOR$ STRING TO SEARCH FOR
'
' OUTPUT PARAMETERS -- WHERE.FOUND POSITION IN LOOK.IN$ THAT
' LOOK.FOR$ FOUND
' NUM.FINDS HOW MANY OCCURENCES IN LOOK.IN$
'
' SUBROUTINE PURPOSE -- FINDS LAST OCCURANCE OF LOOK.FOR$ IN LOOK.IN$ AND
' RETURNS COUNT OF # OF OCCURANCES. IF NONE FOUND,
' BOTH RETURNED PARAMETERS ARE SET TO 0.
'
SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC
58600 WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$)
NUM.FINDS = -(WHERE.FOUND > 0)
NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
WHILE NEXT.FOUND > 0
NUM.FINDS = NUM.FINDS + 1
WHERE.FOUND = NEXT.FOUND ' FORMAT
NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
WEND
END SUB
' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file'
' $PAGE
'
' SUBROUTINE NAME -- ROTORSDIR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ FILE NAME TO LOOK FOR
' SDIR.ARA ARRAY OF SUBDIRECTORIES
' MAX.SEARCH MAX # OF SUBDIRECTORIES
' MARK.TIME WHETHER TO MARK TIME
'
' OUTPUT PARAMETERS -- FNAME$ ADD SUBDIRECTORY TO THE
' FILE NAME IF FOUND. OTHER-
' WISE DON'T.
' OK TRUE IF FILE WAS FOUND
'
' SUBROUTINE PURPOSE -- HUNT THROUGH A LIST OF SUBDIRECTORIES TO DETERMINE
' IF A FILE IS IN ANY OF THEM. IF FILE IS FOUND, OPEN
' THE FILE AS FILE #2, ADD THE DRIVE/PATH TO THE FILE
' NAME, AND SETS OK TO TRUE. IF FILE ISN'T FOUND, SET
' FILE NAME TO THE LAST SUBDIRECTORY SEARCHED -- WHICH
' SHOULD BE THE UPLOAD SUBDIRECTORY.
'
' IF THE LIBRARY MENU IS SELECTED (MENU.INDEX = 6), THEN
' ONLY 2 SUBDIRECTORIES ARE SEARCHED. THE FIRST BEING
' THE WORK DISK AND THE SECOND BEING THE SELECTED
' LIBRARY DISK.
'
SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH,MARK.TIME) STATIC
58700 OK = FALSE
IF MARK.TIME THEN _
CALL QTPUT ("Searching for "+FILNAME$,0)
IF MENU.INDEX = 6 THEN _
GOTO 58705
NUM.SEARCH = 1
X = 0
WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND _
SDIR.ARA$(NUM.SEARCH) <> ""
IF MARK.TIME THEN _
CALL MARKTIME (X)
X$ = SDIR.ARA$(NUM.SEARCH) + _
FILNAME$
CALL FINDIT (X$)
NUM.SEARCH = NUM.SEARCH + 1
WEND
GOTO 58710
58705 X$ = LIBRARY.WORK.DISK.PATH$ + _
FILNAME$
CALL FINDIT (X$)
IF OK THEN _
GOTO 58710
X$ = LIBRARY.DRIVE$ + _
FILNAME$
CALL FINDIT (X$)
58710 FILNAME$ = X$
CALL SKIPLINE (-MARK.TIME)
END SUB
' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints'
' $PAGE
'
' SUBROUTINE NAME -- WIPELINE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' CARRIAGE.RETURN$
' CHARS.TO.WIPE # OF CHARACTERS TO BLANK
' NULLS
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- WIPE AWAY A LINE AND LEAVE CURSOR AT BEGINNING OF THE
' SAME LINE SO THAT THE NEXT LINE WILL PRINT IN ITS
' PLACE
'
SUB WIPELINE (CHARS.TO.WIPE) STATIC
58800 IF NULLS OR CHARS.TO.WIPE > 79 THEN _
CALL SKIPLINE (1) : _
EXIT SUB
IF NOT LOCAL.USER THEN _
STRNG$ = CARRIAGE.RETURN$ + SPACE$(CHARS.TO.WIPE) + CARRIAGE.RETURN$ : _
IF FOSSIL THEN _
BYTES% = LEN(STRNG$) : _
CALL FOSWRITE(COMPORT%,BYTES%,STRNG$) _
ELSE PRINT #3,STRNG$
IF SNOOP THEN _
LOCATE ,1 : _
CALL LPRNT(SPACE$(CHARS.TO.WIPE),0) : _
LOCATE ,1
IF F7.MESSAGE$ = "" OR _
F7.MESSAGE$ = "NONE" OR _
NOT SYSOP.NEXT THEN _
EXIT SUB
BYPASS.TIME.CHECK = TRUE
CALL BUFFILE (F7.MESSAGE$,X)
END SUB
' $SUBTITLE: 'GETDIRS -- Prompt for directories to search'
' $PAGE
'
' SUBROUTINE NAME -- GETDIRS
'
' INPUT PARAMETERS -- PARAMETER MEANING
' DIR.PROMPT$ BASE OF DIRECTORY PROMPT
' SHOW.HELP Whether to display help
' on entry
' OUTPUT PARAMETERS -- B$
' Q
' SUBROUTINE PURPOSE -- Prompt for directories to search
'
SUB GETDIRS (SHOW.HELP) STATIC
IF SHOW.HELP THEN _
GOTO 58902
58900 A$ = DIR.PROMPT$
SUBROUTINE.PARAMETER = 1
CALL TGET
IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
CALL ALLCAPS (B$(1))
IF B$(1) = "Q" THEN _
Q = 0 : _
EXIT SUB
A = INSTR("E+.E-.E.L.H.?.",B$(1)+".")
IF A = 0 THEN _
EXIT SUB
IF A > 8 THEN _
GOTO 58901
IF A = 7 THEN _
EXTENDED.OFF = NOT EXTENDED.OFF _
ELSE EXTENDED.OFF = (A > 3)
CALL QTPUT ("Extended directory display "+MID$("ON OFF",1-3*EXTENDED.OFF,3),1)
GOTO 58900
58901 IF A = 9 AND Q > 1 THEN _
Q = Q - 1 : _
FOR B = 1 TO Q : _
B$(B) = B$(B + 1) : _
NEXT : _
EXIT SUB
58902 FILE.NAME$ = DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + _
"." + DIRECTORY.EXTENTION$
GDEFAULT$ = MID$(" GC",GR + 1, 1)
CALL GRAPHIC (GDEFAULT$)
CALL BUFFILE (FILE.NAME$,X)
GOTO 58900
END SUB
'
' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory'
' $PAGE
'
' SUBROUTINE NAME -- CONVDIRS
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRT ELEMENT TO BEGIN WITH
' B$ ARRAY TO CONVERT
' Q LAST ELEMENT TO CONFERT
'
' OUTPUT PARAMETERS -- B$ CONVERTED DIRECTORY LIST
'
' SUBROUTINE PURPOSE -- LET THE USER PUT IN A SHORT STANDARD STRING FOR A
' DIRECTORY
'
'
58950 SUB CONVDIRS (STRT) STATIC
FOR I=STRT TO Q
CALL ALLCAPS (B$(I))
IF B$(I)="U" THEN _
B$(I) = UPLOAD.DIR.CHECK$
IF B$(I) = "A" THEN _
B$(I) = "ALL"
NEXT
END SUB
' $SUBTITLE: 'MUZAK - subroutine to PLAY MUSIC'
' $PAGE
'
' SUBROUTINE NAME -- MUZAK
'
' INPUT PARAMETERS -- PARAMETER MEANING
' 1 PLAY CONSIDER YOURSELF(OPENING SCREEN)
' 2 PLAY WALK RIGHT IN(NEW USERS)
' 3 PLAY DRAGNET (SECURITY VIOLATION)
' 4 PLAY GOODBYE CHARLIE (GOODBYE)
' 5 PLAY TAPS (ACCESS DENIED)
' 6 PLAY OOM PAH PAH (DOWNLOAD)
' 7 PLAY THNKS FOR MEMORIES(UPLOAD)
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- PROVIDE SYSOP'S AND THE VISUALLY IMPARED WITH
' AUDITORY FEEDBACK ON WHAT RBBS-PC IS DOING
'
SUB MUZAK (PASSED.ARG) STATIC
59100 FF = PASSED.ARG
SUBROUTINE.PARAMETER = 0
IF (NOT SNOOP) OR (NOT MUSIC) OR LOCAL.USER.MODE THEN _
EXIT SUB
ON FF GOTO 59102,59104,59106,59108,59110,59112,59114
EXIT SUB
59102 '---[Introduction CONSIDER YOURSELF]---
LEC$ = "MBT180A4B-8B-8B-8B-2.G4A8F2"
PLAY "O2 X" + VARPTR$(LEC$)
EXIT SUB
59104 '---[New User WALK RIGHT IN]---
LEC1$ = "MBT180G4G4D2G8F+8F8E2A8B8"
LEC2$ = "C8C+8D8C8"
LEC3$ = "B4G2"
PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
EXIT SUB
59106 '---[Security Violation DRAGNET THEME]---
LEC$ = "MBT120C2D8E-4C2.C2D8E-4C4G-2."
PLAY "O2 X" + VARPTR$(LEC$)
EXIT SUB
59108 '---[Goodbye GOODBYE CHARLIE]---
LEC$ = "MBT180B-2.G2.F4D2."
PLAY "O2 X" + VARPTR$(LEC$)
EXIT SUB
59110 '---[Access Denied TAPS]---
LEC1$ = "MBT90F8A16"
LEC2$ = "C4."
LEC3$ = "A4F4C2.C8C16F2"
PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
EXIT SUB
59112 '---[Download OOM PAH PAH]---
LEC$ = "MBT180F4A4A4C4A4A4G4A4G4D2"
PLAY "O2 X" + VARPTR$(LEC$)
EXIT SUB
59114 '---[Upload THANKS FOR THE MEMORIES]---
LEC1$ = "MBT180C2."
LEC2$ = "A8G8F4D2"
PLAY "O3 X" + VARPTR$(LEC1$) + "O2 X" + VARPTR$(LEC2$)
END SUB
' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in two bytes'
' $PAGE
'
' SUBROUTINE NAME -- TWOBYTEDATE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' YY FOUR DIGIT YEAR (I.E. 1987)
' MM MONTH
' DD DAY
' RESULT$ LOCATION TO PLACE THE RESULT
'
' OUTPUT PARAMETERS -- RESULT$ TWO BYTE COMPRESSED DATE FOR USE IN
' A RANDOM RECORD
'
' SUBROUTINE PURPOSE -- COMPRESS AN Y,M,D DATE INTO TWO CHARACTERS
SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC
59200 RESULT$ = CHR$(((YY - 1980) * 2) OR - ((MM AND 8) <> 0)) + _
CHR$((MM AND NOT 8) * 32 + DD)
END SUB
' $SUBTITLE: 'CSTRDATE -- subroutine to Compress STRing DATE'
' $PAGE
'
' SUBROUTINE NAME -- CSTRDATE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ String Date (mm-dd-yyyy)
'
' OUTPUT PARAMETERS -- RESULT$ TWO BYTE COMPRESSED DATE FOR USE IN
' A RANDOM RECORD
'
' SUBROUTINE PURPOSE -- COMPRESS AN 8-CHARACTER DATE INTO TWO CHARACTERS
SUB CSTRDATE (STRNG$,RESULT$) STATIC
IF LEN(STRNG$) < 8 THEN _
EXIT SUB
YY = VAL(MID$(STRNG$,7))
MM = VAL(STRNG$)
DD = VAL(MID$(STRNG$,4))
CALL TWOBYTEDATE (YY,MM,DD,RESULT$)
END SUB
' $SUBTITLE: 'UNCDATE -- subroutine to UNCompress DATE'
' $PAGE
'
' SUBROUTINE NAME -- UNCDATE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' COMPRESSED.DATE$ Date in 2 byte compressed form
'
' OUTPUT PARAMETERS -- YY Year of compressed date
' MM Month of compressed date
' DD Day of compressed date
' DISPLAY.DATE$ 8 char display date (mm-dd-yyyy)
'
' SUBROUTINE PURPOSE -- Uncompress a 2 char date to get Y,M,D & display
'
SUB UNCDATE (COMPRESSED.DATE$,YY,MM,DD,DISPLAY.DATE$) STATIC
CALL GETYMD (COMPRESSED.DATE$,1,YY)
CALL GETYMD (COMPRESSED.DATE$,2,MM)
CALL GETYMD (COMPRESSED.DATE$,3,DD)
DISPLAY.DATE$ = RIGHT$("00" + MID$(STR$(MM),2),2) + _
"-" + _
RIGHT$("00" + MID$(STR$(DD),2),2) + _
"-" + _
RIGHT$(STR$(YY),2)
END SUB
' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date'
' $PAGE
'
' SUBROUTINE NAME -- GETYMD
'
' INPUT PARAMETERS -- PARAMETER MEANING
' TWOBYTE$ PACKED TWO-BYTE DATE FIELD
' YMD 1 = YEAR
' 2 = MONTH
' 3 = DAY
' RESULT LOCATION TO PLACE THE RESULT
'
' OUTPUT PARAMETERS -- RESULT FOUR DIGIT RESULT OF UNPAKING THE DATE
'
' SUBROUTINE PURPOSE -- UNPACK A COMPRESSED TWO-BYTE DATE FIELD
'
SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC
ON YMD GOTO 59205,59210,59215
EXIT SUB
59205 RESULT = (ASC(TWOBYTE$)AND NOT 1) / 2 + 1980
EXIT SUB
59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2)) / 32)) OR ((ASC(TWOBYTE$) AND 1) * 8)
EXIT SUB
59215 RESULT = ASC(MID$(TWOBYTE$,2)) AND NOT 224
END SUB
' $SUBTITLE: 'PERSFILE - subroutine to process requests for personal files'
' $PAGE
'
' SUBROUTINE NAME -- PERSFILE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' PERSONAL.CAT$ CATEGORY IN DIR FOR CALLER
' PERSONAL.LEN # CHARS IN PERSONAL CATEGORY
' OUTPUT PARAMETERS -- NONE UP DOWNLOADS
'
' SUBROUTINE PURPOSE -- SHOW CALLER WHAT PERSONAL FILES HAVE FOR
' DOWNLOADING, VERIFY AND PROCESS REQUESTS FOR
' DOWNLOADS
'
59300 SUB PERSFILE (PERSONAL.CAT$,DOWNLOAD.FLAG) STATIC
CALL FINDIT (PERSONAL.DIR$)
59302 IF NOT OK THEN _
CALL QTPUT ("No personal files available",1) : _
Q = 0 : _
EXIT SUB
L = 36 + MAX.DESC.LEN + PERSONAL.LEN
IF LOF(2) < L THEN _
OK = FALSE : _
GOTO 59302
B$(0) = ""
CLOSE 2
IF SHARE.IT THEN _
OPEN PERSONAL.DIR$ FOR RANDOM SHARED AS #2 LEN=L _
ELSE OPEN "R",2,PERSONAL.DIR$,L
FIELD #2,33 + MAX.DESC.LEN AS PART.TO.PRINT$, _
PERSONAL.LEN AS PRIVATE.CAT$, _
1 AS PERSONAL.STATUS$, _
2 AS FILLER$
MAX.PRINT = PAGE.LENGTH - 1
NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
LAST.REC = LOF(2) / L
IF DOWNLOADING THEN _
DOWNLOADING = FALSE : _
PERS.INDEX = DOWNLOAD.FLAG : _
DOWNLOAD.FLAG = 0 : _
GOTO 59306
IF Q > 1 THEN _
FOR I = 2 TO Q : _
B$(I - 1) = B$(I) : _
NEXT : _
Q = Q - 1 : _
GOTO 59304
59303 A$ = "Download what: L)ist, * = new, or file(s)" + _
PRESS.ENTER.EXPERT$
SUBROUTINE.PARAMETER = 1
CALL TGET
IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
EXIT SUB
59304 SELECTED.PROTOCOL$ = ""
IF Q > 1 THEN _
IF LEN(B$(Q)) = 1 THEN _
SELECTED.PROTOCOL$ = B$(Q) : _
Q = Q - 1
IF LEN(B$(1)) > 2 THEN _
GOTO 59330
CALL ALLCAPS (B$(1))
ON INSTR("L*",B$(1)) GOTO 59305,59327
GOTO 59303
59305 PERS.INDEX = LAST.REC
L = FALSE
59306 IF PERS.INDEX < 1 THEN _
IF L THEN _
GOTO 59303 _
ELSE _
A$ = "No files for you" : _
CALL QTPUT (A$,1) : _
GOTO 59303
GET #2,PERS.INDEX
PERS.INDEX = PERS.INDEX - 1
IF SYSOP THEN _
GOTO 59320
IF ASC(PRIVATE.CAT$) = 32 THEN _
IF USER.SECURITY.LEVEL < VAL(PRIVATE.CAT$) THEN _
GOTO 59306 _
ELSE GOTO 59308
IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
GOTO 59306
59308 L = TRUE
FILNAME$ = PERSONAL.DRVPATH$ + _
LEFT$(PART.TO.PRINT$,12)
59320 IF PERSONAL.STATUS$ = "*" THEN _
A$ = "*" + PART.TO.PRINT$ _
ELSE A$ = " " + PART.TO.PRINT$
CALL COLORDIR (A$,"N")
IF LOCAL.USER THEN _
GOTO 59322
CALL EOFCOMM (CHAR%)
IF CHAR% <> -1 THEN _
GOTO 59323 ' comm port input
59322 KEYBOARD.STACK$ = INKEY$
IF KEYBOARD.STACK$ = "" THEN _ ' no keyboard input
CALL QTPUT (A$,1) : _
GOTO 59324
59323 SUBROUTINE.PARAMETER = 1
CALL TPUT
IF RET THEN _
GOTO 59303
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 59335
59324 IF LINES.PRINTED <= MAX.PRINT THEN _
GOTO 59306
CALL TIMEREMAIN (TIME.REMAINING!)
IF TIME.REMAINING! < 0.1 THEN _
SUBROUTINE.PARAMETER = -1 : _
GOTO 59335
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 59335
IF NON.STOP THEN _
GOTO 59306
59325 IF PERS.INDEX > 0 THEN _
A$ = "MORE: [Y],N,C or download what (* = new)" _
ELSE GOTO 59303
SUBROUTINE.PARAMETER = 1
NO.ADVANCE = TRUE
CALL TGET
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 59335
NON.STOP = (NON.STOP OR INSTR(" Cc",B$) > 1)
IF PERS.INDEX < 1 AND Q = 0 THEN _
GOTO 59335
CALL WIPELINE (78)
IF NO THEN _
GOTO 59303
IF LEN(B$(1)) > 2 THEN _
GOTO 59304
GOTO 59306
59327 PERS.INDEX = LAST.REC ' handle new files
Q = 0
WHILE PERS.INDEX > 0 AND Q < UBOUND(B$)
GET 2,PERS.INDEX
IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
GOTO 59329
IF PERSONAL.STATUS$ <> "*" THEN _
GOTO 59329
Q = Q + 1
I = Q
GOSUB 59336
IF OK THEN _
X$ = MID$(STR$(PERS.INDEX),2) : _
B$(0) = B$(0) + _
X$ + _
SPACE$(5 - LEN(X$)) _
ELSE Q = Q - 1
59329 PERS.INDEX = PERS.INDEX - 1
WEND
IF Q = 0 THEN _
A$ = "No new files for you" : _
CALL QTPUT (A$,1) : _
GOTO 59303
GOTO 59332
59330 I = 1 ' handle list of files
WHILE I <= Q
OK = FALSE
J = LAST.REC + 1
CALL ALLCAPS (B$(I))
WHILE J > 1 AND NOT OK
J = J - 1
GET #2,J
IF (PERSONAL.CAT$ = PRIVATE.CAT$ OR _
(ASC(PRIVATE.CAT$) = 32 AND _
USER.SECURITY.LEVEL => VAL(PRIVATE.CAT$))) THEN _
OK = (B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1))
WEND
IF OK THEN _
GOSUB 59336 : _
IF OK THEN _
X$ = MID$(STR$(J),2) : _
B$(0) = B$(0) + _
X$ + _
SPACE$(5 - LEN(X$))
IF NOT OK THEN _
CALL QTPUT (B$(I) + " not found - omitted",1) : _
FOR K = I + 1 TO Q : _
B$(K - 1) = B$(K) : _
NEXT : _
Q = Q - 1 : _
I = I - 1
I = I + 1
WEND
IF Q = 0 THEN _
GOTO 59303
59332 DOWNLOAD.FLAG = PERS.INDEX ' set protocol
DOWNLOADING = TRUE
B = 1
IF SELECTED.PROTOCOL$ = "" THEN _
IF PERSONAL.PROTOCOL$ <> " " THEN _
SELECTED.PROTOCOL$ = PERSONAL.PROTOCOL$
IF SELECTED.PROTOCOL$ <> "" THEN _
Q = Q + 1 : _
B$(Q) = SELECTED.PROTOCOL$
EXIT SUB
59335 CLOSE 2
EXIT SUB
59336 B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1)
CALL RBBSFIND (PERSONAL.DRVPATH$ + B$(I),Z,K,L,M)
OK = (Z = 0)
IF OK THEN _
B$(I) = PERSONAL.DRVPATH$ + B$(I) _
ELSE K = 0 : _
WHILE K < SUBDIR.COUNT AND NOT OK : _
K = K + 1 : _
CALL RBBSFIND (SUBDIR$(K) + B$(I),Z,X,L,M) : _
OK = (Z=0) : _
WEND : _
IF OK THEN _
B$(I) = SUBDIR$(K) + B$(I)
RETURN
END SUB
' $SUBTITLE: 'LOGDOWN -- subroutine to record private downloads'
' $PAGE
'
' SUBROUTINE NAME -- LOGDOWN
'
' INPUT PARAMETERS -- PARAMETER MEANING
'
' OUTPUT PARAMETERS --
'
' SUBROUTINE PURPOSE -- PUTS A "!" IN PLACE OF AN "*" IN PRIVATE
' DIRECTORY AFTER DOWNLOADED
'
59400 SUB LOGDOWN (PRIVATE.DOWNLOAD,DWN.INDEX) STATIC
IF NOT PRIVATE.DOWNLOAD THEN _
EXIT SUB
EN$ = PERSONAL.DIR$
BX = &H4
SUBROUTINE.PARAMETER = 9
CALL FILELOCK
L = 36 + MAX.DESC.LEN + PERSONAL.LEN
CLOSE 2
IF SHARE.IT THEN _
OPEN EN$ FOR RANDOM SHARED AS #2 LEN=L _
ELSE OPEN "R",2,PERSONAL.DIR$,L
FIELD #2,L AS PERSONAL.REC$
A = VAL(MID$(B$(0),5 * (DWN.INDEX - 1) + 1,5))
GET #2,A
MID$(PERSONAL.REC$,L-2,1) = "!"
PUT #2,A
BX = &H4
SUBROUTINE.PARAMETER = 10
CALL FILELOCK
CLOSE 2
END SUB
' $SUBTITLE: 'USERFACE - subroutine to handle programmable user interface'
' $PAGE
'
' SUBROUTINE NAME -- USERFACE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' GDEFAULT$ GRAPHICS DEFAULT TO USE
' CURRENT.PUI$ PUI TO USE
' EXPERT.USER WHETHER CALL IN EXPERT MODE
'
' OUTPUT PARAMETERS -- Q
' B$()
' Z$
'
' SUBROUTINE PURPOSE -- WHEN SYSOP OVERRIDES RBBS-PC's DEFAULT USER
' INTERFACE (PROVIDES A MAIN.PUI), THIS ROUTINE
' READS IN THE TABLE OF SPECIFICATIONS, PRESENTS
' THE SYSOP MENU, PRESENTS THE PROMPT, VERIFIES
' THAT A VALID OPTION HAS BEEN PICKED, DETERMINES
' WHETHER THE OPTION IS ANOTHER PUI, AND PASSES
' BACK CHOICES TO BE PROCESSED.
'
59450 SUB USERFACE (GDEFAULT$) STATIC
59455 IF PREV.PUI$ = CURRENT.PUI$ THEN _
GOTO 59458
59456 FILE.NAME$ = CURRENT.PUI$
CALL GRAPHIC (GDEFAULT$)
IF NOT OK THEN _
CALL UPDTCALR ("Missing menu " + CURRENT.PUI$,2) : _
CURRENT.PUI$ = PREV.PUI$ : _
GOTO 59456
PREV.PUI$ = CURRENT.PUI$
LINE INPUT #2,FILE.NAME$
LINE INPUT #2,PRMPT$
INPUT #2,VALID.CHOICE$,ACTUAL.COMMANDS$
LINE INPUT #2,MENU.CHOICE$
LINE INPUT #2,MENU.NAME$
LINE INPUT #2,QUIT.COMMAND$
LINE INPUT #2,QUIT.PROMPT$
LINE INPUT #2,QUIT.SUBCOMMANDS$
LINE INPUT #2,QUIT.MENUOPT$
LINE INPUT #2,QUIT.MENUS$
CALL GRAPHIC (GDEFAULT$)
CALL BRKFNAME (FILE.NAME$,MENU.DRVPATH$,X$,Y$,TRUE)
MENU.TO.DISPLAY$ = FILE.NAME$
J = INSTR(ORIG.COMMANDS$,"?")
IF J < 1 THEN _
X$ = "" _
ELSE X$ = MID$(ALL.OPTS$,J,1)
59458 IF EXPERT.USER THEN _
GOTO 59461
59460 CALL BUFFILE (MENU.TO.DISPLAY$,X)
59461 A$ = PRMPT$
TURBO.KEY = -TURBO.KEY.USER
SUBROUTINE.PARAMETER = 1
CALL TGET
IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
EXIT SUB
IF Q = 0 THEN _
GOTO 59458
59462 Z$ = B$(1)
CALL ALLCAPS (Z$)
IN.MACRO = FALSE
J = INSTR(VALID.CHOICE$,Z$)
IF J < 1 THEN _
IF NOT IN.MACRO THEN _
CALL CHKMACRO (Z$,IN.MACRO) : _
IF IN.MACRO THEN _
GOTO 59462 _
ELSE GOTO 59492 _
ELSE GOTO 59492
Z$ = MID$(ACTUAL.COMMANDS$,J,1)
B$(1) = Z$
J = INSTR(MENU.CHOICE$,Z$)
IF J > 0 THEN _
CURRENT.PUI$ = MID$(MENU.NAME$,1 + (J - 1) * 7,7) : _
GOTO 59490
IF Z$ = X$ THEN _
GOTO 59460
IF Z$ <> QUIT.COMMAND$ THEN _
EXIT SUB
IF Q > 1 THEN _
Y = 2 : _
GOTO 59480
59470 A$ = QUIT.PROMPT$
TURBO.KEY = -TURBO.KEY.USER
CALL TGET
IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
EXIT SUB
IF Q = 0 THEN _
GOTO 59458
Y = 1
59480 Z$ = B$(Y)
CALL ALLCAPS (Z$)
J = INSTR(QUIT.SUBCOMMANDS$,Z$)
IF J < 1 THEN _
GOTO 59470
J = INSTR(QUIT.MENUOPT$,Z$)
IF J > 0 THEN _ 'quit to submenu
CURRENT.PUI$ = MID$(QUIT.MENUS$,1 + (J - 1) * 7,7) : _
GOTO 59490
IF Q = 1 THEN _ 'valid but not menu - send to RBBS
Q = 2 : _
B$(2) = B$(1) : _
B$(1) = QUIT.COMMAND$
EXIT SUB
59490 CALL REMOVE (CURRENT.PUI$," ")
CURRENT.PUI$ = MENU.DRVPATH$ + _
CURRENT.PUI$ + _
".PUI"
GOTO 59455
59492 CALL QTPUT (Z$ + " not valid choice",1)
GOTO 59460
END SUB
' $SUBTITLE: 'SUBMENU -- subroutine to process menus'
' $PAGE
'
' SUBROUTINE NAME -- SUBMENU
'
' INPUT PARAMETERS -- PARAMETER MEANING
' PASSED.PROMPT$ PROMPT TO DISPLAY
' CURRENT.MENU$ NOVICE MENU TO DISPLAY
' FRONT.OPT$ DRIVE/PATH/PREFIX OF FILE
' NEEDED FOR TYPED OPTION
' BACK.OPT$ SUFFIX/EXTENSION OF FILE
' NEEDED WITH TYPED OPTION
' RETURN.ON$ LETTERS CALLING PROGRAM WANTS
' CONTROL ON
' GR.DEFAULT$ GRAPHICS DEFAULT TO USE
' VERIFY.IN.MENU WHETHER VERIFY OPTION IS IN MENU
' ALL.MENU.OK WHETHER CONTROL SHOULD RETURN
' WHEN IN MENU
' ANS.INDEX # OF COMMANDS IN TYPE AHEAD
' REQUIRE.IN.MENU WHETHER OPTION MUST BE IN MENU
'
' OUTPUT PARAMETERS -- Z$ OPTION PICKED
' FILE.NAME$ NAME OF FILE SUPPORTING OPTION
'
'
' SUBROUTINE PURPOSE -- HANDLES MENUS - INCLUDING CONFERENCE, BULLETINS,
' DOORS, QUESTIONAIRES. SUPPORTS SUB-MENUS (I.E.
' AN OPTION ON THE MENU THAT INVOKES ANOTHER MENU)
'
59500 SUB SUBMENU (PASSED.PROMPT$,CURRENT.MENU$,FRONT.OPT$, _
BACK.OPT$,RETURN.ON$,GR.DEFAULT$,VERIFY.IN.MENU, _
ALL.MENU.OK,REQUIRE.IN.MENU) STATIC
59510 FILE.NAME$ = CURRENT.MENU$
CALL GRAPHIC (GR.DEFAULT$)
CURRENT.MENU.VER$ = FILE.NAME$
STOP.INTERRUPTS = FALSE
IF ANS.INDEX > 1 THEN _
Q = 1 : _
GOTO 59530
IF EXPERT.USER THEN _
GOTO 59520
59515 CALL BUFFILE (CURRENT.MENU.VER$,ANS.INDEX) 'show menu
59520 A$ = PASSED.PROMPT$ 'get response
SUBROUTINE.PARAMETER = 1
CALL TGET
IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
ANS.INDEX = 1
LAST.INDEX = Q
59530 Z$ = B$(ANS.INDEX)
CALL ALLCAPS (Z$)
IF INSTR(RETURN.ON$,Z$) THEN _ 'check whether calling pgm wants
EXIT SUB
IF INSTR("LH?",Z$) THEN _ 'check whether caller wants help
GOTO 59515
IF INSTR(Z$,".") > 0 THEN _
GOTO 59545
FILE.NAME$ = FRONT.OPT$ + _
Z$
CALL BADFILE (FILE.NAME$,A)
IF A > 1 THEN _
GOTO 59547
FILE.NAME$ = FILE.NAME$ + _
BACK.OPT$
CALL GRAPHIC (GR.DEFAULT$)
IF OK THEN _
IF NOT REQUIRE.IN.MENU THEN _
EXIT SUB _
ELSE CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) : _
IF FOUND THEN _
EXIT SUB _
ELSE GOTO 59540
IF NOT VERIFY.IN.MENU THEN _
GOTO 59540
CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) 'verify against menu itself
IF FOUND THEN _
IF ALL.MENU.OK THEN _
EXIT SUB
59540 X$ = FRONT.OPT$ + _
Z$ + _
".MNU" 'check whether option is a menu
FILE.NAME$ = X$
CALL GRAPHIC (GR.DEFAULT$)
IF OK THEN _
CURRENT.MENU.VER$ = FILE.NAME$ : _
CURRENT.MENU$ = X$ : _
GOTO 59515
IF VERIFY.IN.MENU AND FOUND AND NOT REQUIRE.IN.MENU THEN _
CALL UPDTCALR("Option " + Z$ + " on menu " + _
CURRENT.MENU$ + " but not found",1)
59545 IF INSTR(RETURN.ON$,LEFT$(Z$,1)) > 0 THEN _
EXIT SUB
59547 CALL QTPUT ("No such option " + Z$,1)
GOTO 59515
END SUB
' $SUBTITLE: 'SETECHO -- subroutine to reset who echoes'
' $PAGE
'
' SUBROUTINE NAME -- SETECHO
'
' INPUT PARAMETERS -- PARAMETER MEANING
' NEW.ECHO$ The new echo option
' LOCAL.USER
'
' OUTPUT PARAMETERS -- REMOTE.ECHO Whether RBBS is to echo what a
' remote caller types
'
' SUBROUTINE PURPOSE -- Resets who echos. "R" is for RBBS to echo.
' "I" is for intermediate host to echo.
' "C" is for caller's communication pgm to echo.
'
59600 SUB SETECHO (NEW.ECHO$) STATIC
IF NEW.ECHO$ = PREV.ECHO$ THEN _
EXIT SUB
IF NEW.ECHO$ = "R" THEN _
REMOTE.ECHO = (NOT LOCAL.USER) _
ELSE REMOTE.ECHO = FALSE
IF LOCAL.USER THEN _
GOTO 59602
IF NEW.ECHO$ = "I" THEN _
IF FOSSIL THEN _
BYTES% = LEN(HOST.ECHO.ON$) : _
CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.ON$) : _
GOTO 59602 _
ELSE PRINT #3,HOST.ECHO.ON$; : _
GOTO 59602
IF PREV.ECHO$ = "I" THEN _
IF FOSSIL THEN _
BYTES% = LEN(HOST.ECHO.OFF$) : _
CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.OFF$) _
ELSE PRINT #3,HOST.ECHO.OFF$;
59602 PREV.ECHO$ = NEW.ECHO$
END SUB
' $SUBTITLE: 'MIMPORT -- subroutine to import a message'
' $PAGE
'
' SUBROUTINE NAME -- MIMPORT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' MAX.LINES MAXIMUM # OF LINES
' MAX.LEN MAXIMUM LENGTH OF A LINE
' NUM.LINES NUMBER OF LINES ALREADY IN MESSAGE
' LINE.ARA$ ARRAY OF LINES IN MESSAGE
'
' OUTPUT PARAMETERS NUM.LINES
' LINE.ARA$
'
' SUBROUTINE PURPOSE -- ALLOWS LOCAL USER TO APPEND A TEXT FILE TO
' A MESSAGE. WILL WORD WRAP IF NECESSARY.
'
SUB MIMPORT (MAX.LINES,MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
IF NOT (LOCAL.USER OR SYSOP) THEN _
CALL QTPUT ("Only for SYSOPS/local users",1) : _
EXIT SUB
59700 SUBROUTINE.PARAMETER = 1
A$ = "Import what file" + PRESS.ENTER$
CALL TGET
IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
EXIT SUB
CALL FINDIT (B$)
IF NOT OK THEN _
CALL QTPUT (B$ + " not found",1) : _
GOTO 59700
WHILE NOT EOF(2) AND NUM.LINES < MAX.LINES
NUM.LINES = NUM.LINES + 1
LINE INPUT #2,LINE.ARA$(NUM.LINES)
WEND
CLOSE 2
CALL WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$())
END SUB
' $SUBTITLE: 'WORDWRAP -- subroutine to wrap lines in a message'
' $PAGE
'
' SUBROUTINE NAME -- WORDWRAP
'
' INPUT PARAMETERS -- PARAMETER MEANING
' MAX.LEN MAXIMUM LENGTH OF A SINGLE LINE
' NUM.LINES NUMBER OF LINES IN A MESSAGE
' LINE.ARA$ ALL THE LINES IN THE MESSAGE
'
' OUTPUT PARAMETERS NUM.LINES
' LINE.ARA$
'
' SUBROUTINE PURPOSE -- BATCH ADJUSTS A MESSAGE, WRAPPING LINES IF
' NEEDED. PRESERVES PARAGRAPH STRUCTURE.
'
SUB WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
J = 1
WHILE J <= NUM.LINES
CALL TRIMTRAIL (LINE.ARA$(J)," ")
K = LEN(LINE.ARA$(J))
IF K <= MAX.LEN THEN _
GOTO 59705
CALL FINDLAST (LINE.ARA$(J)," ",LAST.POS,HOW.MANY)
IF LEFT$(LINE.ARA$(J + 1),2) = " " THEN _
FOR K = NUM.LINES TO J + 1 STEP -1 : _
LINE.ARA$(K + 1) = LINE.ARA$(K) : _
NEXT : _
NUM.LINES = NUM.LINES + 1 : _
LINE.ARA$(J + 1) = ""
IF LAST.POS < 1 THEN _
LINE.ARA$(J + 1) = MID$(LINE.ARA$(J),MAX.LEN) + LINE.ARA$(J + 1) : _
LINE.ARA$(J) = LEFT$(LINE.ARA$(J),MAX.LEN - 1) + "-" _
ELSE B$ = LEFT$(" ", - (LEN(LINE.ARA$(J + 1)) > 0)) : _
LINE.ARA$(J + 1) = MID$(LINE.ARA$(J),LAST.POS + 1) + B$ + LINE.ARA$(J + 1) : _
LINE.ARA$(J) = LEFT$(LINE.ARA$(J),LAST.POS - 1)
59705 J = J + 1
WEND
NUM.LINES = NUM.LINES - (LEN(LINE.ARA$(NUM.LINES + 1)) > 0)
END SUB
' $SUBTITLE: 'SETABORT -- subroutine to set a time-limit'
' $PAGE
'
' SUBROUTINE NAME -- SETABORT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SECONDS.TO.ADD # SECONDS AFTER CURRENT TIME
' WHEN TIME LIMIT IS TO EXPIRE
'
' OUTPUT PARAMETERS ABORT.TIME! THE TIME (IN SECONDS AFTER MIDNIGHT)
' WHEN TIME LIMIT EXPIRES
'
' SUBROUTINE PURPOSE -- SETS A TIME LIMIT IN UNITS OF SECONDS AFTER
' MIDNIGHT AFTER WHICH A TIME LIMIT WILL EXPIRE.
' CALLING PROGRAM PASSES NUMBER OF SECONDS THAT CAN
' ELASPE BEFORE TIME-LIMIT IS REACHED.
'
59750 SUB SETABORT (ABORT.TIME!,SECONDS.TO.ADD) STATIC
CALL FINDTIME (ABORT.TIME!)
ABORT.TIME! = ABORT.TIME! + SECONDS.TO.ADD
END SUB
' $SUBTITLE: 'ANYBUT -- subroutine to find where a word begins'
' $PAGE
'
' SUBROUTINE NAME -- ANYBUT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ STRING TO SEARCH FOR WORDS
' BEG% BYTE POSITION IN STRNG$ TO
' BEGIN SEARCHING
' SKIP.CHARS$ CHARACTERS TO SKIP OVER WHEN
' SEARCHING
'
' OUTPUT PARAMETERS WHEREIS% BYTES POSITION IN STRNG$ WHERE
' WORD BEGINS
'
' SUBROUTINE PURPOSE -- PARSER. FINDS WHERE A "WORD" BEGINS, WHERE
' ANY CHARACTER WILL BE ACCEPTED AS THE BEGINNING OF A
' WORD EXCEPT THOSE LISTED IN SKIP.CHAR$
'
59760 SUB ANYBUT (STRNG$, BEG%, SKIP.CHARS$, WHEREIS%) STATIC
X$ = STRNG$ + _
CHR$(0)
WHEREIS% = BEG%
IF WHEREIS% < 1 THEN _
WHEREIS% = 1
WHILE INSTR(SKIP.CHARS$, MID$(X$, WHEREIS%, 1)) > 0
WHEREIS% = WHEREIS% + 1
WEND
IF WHEREIS% > LEN(STRNG$) THEN _
WHEREIS% = 0
END SUB
' $SUBTITLE: 'FINDEND -- subroutine to find where a word ends'
' $PAGE
'
' SUBROUTINE NAME -- FINDEND
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ STRING TO SEARCH FOR WORDS
' BEG% POSITION IN STRNG$ TO BEGIN SEARCH
' STOP.WITH$ CHARACTERS THAT TERMINATE A WORD
'
' OUTPUT PARAMETERS WHEREIS% POSITION IN STRNG$ WHERE WORD ENDS
' (I.E. THE LAST CHARACTER OF THE WORD)
'
' SUBROUTINE PURPOSE -- PARSER. FINDS WHERE A "WORD" ENDS, WHERE
' ANY CHARACTER WILL BE COUNTED AS IN A WORD
' EXCEPT FOR THOSE IN STOP.WITH$ OR WHEN THE END OF
' THE STRING IS FOUND.
'
59770 SUB FINDEND (STRNG$, BEG%, STOP.WITH$, WHEREIS%) STATIC
B = BEG%
IF B < 1 THEN _
B = 1
IF B > LEN(STRNG$) THEN _
X$ = STOP.WITH$ _
ELSE X$ = MID$(STRNG$, B) + _
STOP.WITH$
I = 1
X = INSTR(STOP.WITH$, MID$(X$, I, 1))
WHILE X = 0
I = I + 1
X = INSTR(STOP.WITH$, MID$(X$, I, 1))
WEND
WHEREIS% = I - 1 + B - 1
END SUB
' $SUBTITLE: 'GETALL -- subroutine to create directory list'
' $PAGE
'
' SUBROUTINE NAME -- GETALL
'
' INPUT PARAMETERS -- PARAMETER MEANING
' LOOK.IN$ NAME OF FILE TO SEARCH
' DIR.EXT$ MAIN DIRECTORY EXTENSION TO USE
' START.POS LAST POSITION USED IN ARRAY
'
' OUTPUT PARAMETERS START.POS LAST ELEMENT USED IN ARRAY
' LOAD.INTO$ ARRAY TO LOAD ELEMENTS FOUND
'
' SUBROUTINE PURPOSE -- CREATES A LIST (LOAD.INTO$) OF ALL DIRECTORIES
' FOUND IN DIRECTORY OF DIRECTORIES (LOOK.IN$).
' USED FOR DETERMING WHAT GETS LISTED WHEN DOING
' AN "ALL" TO DETERMINATE WHAT SEPERATE DIRECTORIES
' TO DISPLAY. DIRECTORY NAME MUST BE ALL CAPS
' AND FOLLOWED BY A SPACE OR DASH.
'
59780 SUB GETALL (LOOK.IN$, LOAD.INTO$(1), DIR.EXT$, START.POS) STATIC
IF MASTER.DIRECTORY.NAME$ <> "" THEN _
START.POS = START.POS + 1 : _
LOAD.INTO$(START.POS) = MASTER.DIRECTORY.NAME$ : _
EXIT SUB
CALL FINDIT(LOOK.IN$)
IF NOT OK THEN _
EXIT SUB
MAX.LOAD = UBOUND(LOAD.INTO$, 1)
START.SORT = START.POS + 1
WHILE NOT EOF(2) AND START.POS < MAX.LOAD
LINE INPUT #2, A$
LAST.POS = LEN(A$)
CALL ANYBUT(A$, 1, " ", X)
WHILE X > 0 AND X < LAST.POS AND START.POS < MAX.LOAD
CALL FINDEND(A$, X + 1, " -.", Y)
L = Y - X + 1
IF L > 8 THEN _
GOTO 59782
B$ = MID$(A$, X, L)
IF B$ = "ALL" THEN _
GOTO 59782
CALL BADFILECHAR (B$,I)
IF NOT I THEN _
GOTO 59782
Z$ = LEFT$(B$,1)
IF (Z$ >= "0" AND Z$ <= "9") OR _
(Z$ >= "A" AND Z$ <= "Z") THEN _
Z$ = B$ : _
CALL ALLCAPS (Z$) : _
IF Z$ = B$ THEN _
LOAD.INTO$(START.POS + 1) = Z$ : _
IF USE.DIR.ORDER THEN _
I = START.SORT : _
WHILE LOAD.INTO$(I) <> Z$ : _
I = I + 1 : _
WEND : _
START.POS = START.POS - (I > START.POS) _
ELSE _
I = START.SORT : _
Z = VAL(Z$) : _
WHILE VAL(LOAD.INTO$(I)) < Z : _
I = I + 1 : _
WEND : _
WHILE VAL(LOAD.INTO$(I)) = Z AND LOAD.INTO$(I) < Z$ AND I <= START.POS : _
I = I + 1 : _
WEND : _
IF I > START.POS THEN _
START.POS = I _
ELSE IF Z$ <> LOAD.INTO$(I) THEN _
FOR J = START.POS TO I STEP -1 : _
LOAD.INTO$(J + 1) = LOAD.INTO$(J) : _
NEXT : _
LOAD.INTO$(I) = Z$ : _
START.POS = START.POS + 1
59782 CALL ANYBUT(A$, Y + 1, " ", X)
WEND
WEND
CLOSE 2
END SUB
' $SUBTITLE: 'FINDFILE -- subroutine to find a file'
' $PAGE
'
' SUBROUTINE NAME -- FINDFILE
'
' INPUT PARAMETERS -- PARAMETER MENANING
' FILNAME$ NAME OF FILE TO LOOK FOR
' FEXISTS WHETHER FILE EXISTS
'
' OUTPUT PARAMETERS -- RETURNED.VALUE VALUE RETURNED
' TRUE = FILE EXISTS
' FALSE = FILE DOES NOT EXIST
'
' SUBROUTINE PURPOSE -- DETERMINE WHETHER PASSED FILE FILNAME$ EXISTS
' UNLIKE, FINDIT, THIS ROUTINE DOES NOT OPEN ANY
' FILE AND, HENCE, DOES NOT CREATE ONE IN DETERMINIG
' IF A FILE EXISTS.
'
59790 SUB FINDFILE (FILNAME$,FEXISTS) STATIC
CALL BADFILECHAR (FILNAME$,FEXISTS)
IF FEXISTS THEN _
CALL RBBSFIND (FILNAME$,Z,Y,M,D) : _
FEXISTS = (Z = 0)
END SUB
' $SUBTITLE: 'BADFILECHAR -- subroutine to check file for illegal char'
' $PAGE
'
' SUBROUTINE NAME -- BADFILECHAR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ NAME OF FILE TO CHECK
'
' OUTPUT PARAMETERS -- IS.OK WHETHER NAME OK
'
' SUBROUTINE PURPOSE -- Part of test for file's existence. If bad
' character in name, can't exist.
'
59800 SUB BADFILECHAR (FILNAME$,IS.OK) STATIC
L = LEN(FILNAME$)
X$ = FILNAME$ + "="
I = 1
WHILE INSTR("/[]|<>+=;,",MID$(X$,I,1)) = 0 AND ASC(MID$(X$,I)) < 128
I = I + 1
WEND
IS.OK = I > L
END SUB
'
' $SUBTITLE: 'CONFMAIL -- subroutine to quickly check mail waiting'
' $PAGE
'
' SUBROUTINE NAME -- CONFMAIL
'
' INPUT PARAMETERS -- PARAMETER MEANING
' CONFMAIL.LIST$ File of user/message pairs to check
' ACTIVE.USER.FILE$ Active user file (restored on exit)
' ACTIVE.MESSAGE.FILE$ Active msg file (restored)
' OUTPUT PARAMETERS -- None
'
' SUBROUTINE PURPOSE -- Quicking scans message header record to get
' last msg # and user record to get whether any
' new mail and last msg read, reports both, using
' highlighting if new mail to caller.
'
59850 SUB CONFMAIL STATIC
IF START.HASH = 1 AND USER.FILE.INDEX > 0 AND START.INDIV = 0 THEN _
CALL FINDIT (CONFMAIL.LIST$) _
ELSE OK = FALSE
IF NOT OK THEN _
EXIT SUB
CALL SKIPLINE (1)
CALL QTPUT ("Checking Message Bases since last on...",1)
ANY.MAIL = FALSE
STOP.INTERRUPTS = FALSE
A1$ = ACTIVE.USER.FILE$
M$ = ACTIVE.MESSAGE.FILE$
TEMP.INDIV.VALUE$ = ""
SUIX = USER.FILE.INDEX
USER.RECORD.HOLD$ = USER.RECORD$
OK = TRUE
59852 IF EOF(2) OR NOT OK THEN _
GOTO 59854
CALL READANY
ACTIVE.USER.FILE$ = A$
CALL READANY
IF EC > 0 THEN _
GOTO 59854
ACTIVE.MESSAGE.FILE$ = A$
CALL FINDFILE (ACTIVE.USER.FILE$,OK)
IF NOT OK THEN _
GOTO 59854
CALL OPENUSER (HIGHEST.USER.RECORD)
FIELD 5, 128 AS USER.RECORD$
CALL FINDFILE (ACTIVE.MESSAGE.FILE$,OK)
IF NOT OK THEN _
GOTO 59854
CALL FINDUSER (ORIG.USER.NAME$,TEMP.INDIV.VALUE$,START.HASH,LEN.HASH,_
START.INDIV,LEN.INDIV,HIGHEST.USER.RECORD,_
FOUND,UFI,SL)
IF NOT FOUND THEN _
GOTO 59852
CALL OPENMSG
FIELD 1, 128 AS MESSAGE.RECORD$
GET 1,1
ANY.MAIL = TRUE
X = CVI(MID$(USER.RECORD$,57,2))
X = (X AND 512) > 0
CALL BRKFNAME (ACTIVE.USER.FILE$,X$,Y$,Z$,FALSE)
A = CVI(MID$(USER.RECORD$,51,2))
B = VAL(LEFT$(MESSAGE.RECORD$,8))
Z = (B - A)
IF Z < 1 THEN _
X = FALSE
A$ = MID$(STR$((B>A)*Z),2)
SL = LEN(A$)
A$ = SPACE$(-(SL<3) * (3-SL)) + A$
SL = LEN(Y$)
Y$ = LEFT$(Y$,SL-1) + SPACE$(-(SL<8) * (8-SL))
IF X THEN _
X$ = EMPHASIZE.ON$ : _
Z$ = EMPHASIZE.OFF$ _
ELSE X$ = "" : _
Z$ = ""
A$ = Y$ + ": " + A$ + " new message(s) - " + _
X$ + MID$("NoneSome",-4*X+1,4) + " to you" + Z$
SUBROUTINE.PARAMETER = 5
CALL TPUT
CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
IF NOT RET THEN _
GOTO 59852
59854 ACTIVE.USER.FILE$ = A1$
CALL OPENUSER (HIGHEST.USER.RECORD)
FIELD 5, 128 AS USER.RECORD$
IF (NOT RET) AND NOT ANY.MAIL THEN _
CALL QTPUT ("No new personal mail",1)
USER.FILE.INDEX = SUIX
LSET USER.RECORD$ = USER.RECORD.HOLD$
ACTIVE.MESSAGE.FILE$ = M$
CALL OPENMSG
FIELD 1, 128 AS MESSAGE.RECORD$
GET 1,1
END SUB
' $SUBTITLE: 'ASKMORE -- subroutine to pause when possible screen full'
' $PAGE
'
' SUBROUTINE NAME -- ASKMORE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' EXTRA.PRMPT$ STRING TO ADD TO MORE PROMPT AT END
' OVERWRITE WHETHER TO WIPE AWAY PROMPT
'
' OUTPUT PARAMETERS -- B$()
' NO
'
' SUBROUTINE PURPOSE -- DETERMINES WHETHER NEED TO PAUSE IF SCREEN FULL.
' AND, IF SO, ASKS THE APPROPRIATE QUESTION. IF NON-
' STOP, AT LEAST CHECK FOR CARRIER PRESENT.
'
SUB ASKMORE (EXTRA.PRMPT$, OVERWRITE, CHECK.LINES,ABORT.INDEX,CANT.INTERRUPT) STATIC
IF CHECK.LINES THEN _
X = -DISPLAY.AS.UNIT*UNIT.COUNT -(NOT DISPLAY.AS.UNIT)*LINES.PRINTED : _
IF X < PAGE.LENGTH THEN _
Q = 0 : _
EXIT SUB
IF ONE.STOP THEN _
ONE.STOP = FALSE : _
NON.STOP = TRUE : _
GOTO 59860
IF NON.STOP THEN _
LINES.PRINTED = 0 : _
NO = FALSE : _
CALL CARRIER : _
IF KEYBOARD.STACK$ = "" AND COMMPORT.STACK$ = "" THEN _
EXIT SUB _
ELSE NON.STOP = FALSE
59860 CALL QTPUT (EMPHASIZE.OFF$,0)
IF CANT.INTERRUPT THEN _
TURBO.KEY = 2 : _
A$ = "Press Any Key to continue" _
ELSE A$ = MORE.PROMPT$ + EXTRA.PRMPT$ + LEFT$(">",-EXPERT.USER)
X = LEN(A$) + 2
NO.ADVANCE = OVERWRITE
SUBROUTINE.PARAMETER = 1
IF EXTRA.PRMPT$ = "" AND TURBO.KEY = 0 THEN _
TURBO.KEY = -TURBO.KEY.USER
CALL TGET
TURBO.KEY = FALSE
NON.STOP = NON.STOP OR (INSTR(" Cc",B$) > 1)
CALL WIPELINE (X + LEN(B$))
IF CANT.INTERRUPT THEN _
NO = FALSE : _
EXIT SUB
IF INSTR(" Aa",B$) > 1 THEN _
ABORT.INDEX = 32000
IF NO THEN _
KEYBOARD.STACK$ = "" : _
COMMPORT.STACK$ = ""
END SUB
' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days'
' $PAGE
'
' SUBROUTINE NAME -- COMPDATE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' YY YEAR
' MM MONTH
' DD DAY
' RESULT! LOCATION TO PLACE THE RESULT
'
' OUTPUT PARAMETERS -- RESULT! COMPUTE COMPUTATIONAL DATE
'
' SUBROUTINE PURPOSE -- COMPUTES A COMPUTATIONAL DATE FROM YEAR, MONTH, DAY.
' RESULTS MAY BE USED TO COMPUTE THE NUMBER OF ELASPED
' DAYS BETWEEN TWO DATES. YOU MAY PASS A 2 OR 4 DIGIT
' YEAR, BUT FOR MEANINGFUL RESULTS, BE CONSISTENT
'
SUB COMPDATE (YY,MM,DD,RESULT!) STATIC
IF MM < 1 OR MM > 12 THEN _
MM = 1
RESULT! = YY * 365.0 + _
INT((YY - 1) / 4) + _
(MM - 1) * 28 + _
VAL(MID$("000303060811131619212426",(MM - 1) * 2 + 1,2)) - _
((MM > 2) AND ((YY MOD 4) = 0)) + _
DD
END SUB
' $SUBTITLE: 'EXPDATE -- subroutine to display expiration date'
' $PAGE
'
' SUBROUTINE NAME -- EXPDATE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' REGISTRATION.DATE! COMPUTATIONAL REGISTRATION DATE
' REGISTRATION.PERIOD DAYS IN REGISTRATION PERIOD
'
' OUTPUT PARAMETERS -- EXP.DATE$ DISPLAYABLE EXPIRATION DATE
'
' SUBROUTINE PURPOSE -- COMPUTES/CREATES A DISPALYABLE REGISTRATION
' EXPIRATION DATE USING REGISTRATION DATE AND DAYS IN
' REGISTRATION PERIOD.
'
SUB EXPDATE (REGISTRATION.DATE!,REGISTRATION.PERIOD,EXP.DATE$) STATIC
EXPIRE.DATE! = REGISTRATION.DATE! + REGISTRATION.PERIOD
EXPIRE.YEAR! = INT((EXPIRE.DATE! - EXPIRE.DATE! / 1461) / 365)
EXPIRE.DAY% = EXPIRE.DATE! - (EXPIRE.YEAR! * 365 + INT((EXPIRE.YEAR! -1)/4))
EXPIRE.MONTH% = -((EXPIRE.YEAR! MOD 4)<>0) * _
(1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 59) - _
(EXPIRE.DAY% > 90) - (EXPIRE.DAY% >120) - _
(EXPIRE.DAY% > 151) - (EXPIRE.DAY% > 181) - _
(EXPIRE.DAY% > 212) - (EXPIRE.DAY% > 243) - _
(EXPIRE.DAY% > 273) - (EXPIRE.DAY% > 304) - _
(EXPIRE.DAY% > 334)) - ((EXPIRE.YEAR! MOD 4) = 0) * _
(1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 60) - _
(EXPIRE.DAY% > 91) - (EXPIRE.DAY% >121) - _
(EXPIRE.DAY% > 152) - (EXPIRE.DAY% > 182) - _
(EXPIRE.DAY% > 213) - (EXPIRE.DAY% > 243) - _
(EXPIRE.DAY% > 274) - (EXPIRE.DAY% > 305) - _
(EXPIRE.DAY% > 335))
EXPIRE.DAY% = (EXPIRE.DAY% - ((EXPIRE.MONTH% - 1) * 28 + _
VAL(MID$("000303060811131619212426",(EXPIRE.MONTH% -1) * 2 + 1,2)))) + _
((EXPIRE.MONTH% > 2) AND ((EXPIRE.YEAR! MOD 4) = 0))
EXP.DATE$ = RIGHT$("0" + MID$(STR$(EXPIRE.MONTH%),2),2) + _
"/" + _
RIGHT$("0" + MID$(STR$(EXPIRE.DAY%),2),2) + _
"/" + _
RIGHT$(STR$(EXPIRE.YEAR!),2)
END SUB
' $SUBTITLE: 'COLORDIR - subroutine to build a color FMS directory string' 'RW060701
' $PAGE 'RW060701
' 'RW060701
' SUBROUTINE NAME -- COLORDIR 'RW060701
' 'RW060701
' INPUT PARAMETERS -- PARAMETER MEANING 'RW060701
' STRNG$ String to alter 'RW060701
' FMS.DIR$ "Y" FOR FMS DIR 'RW060701
' "N" FOR PERSONAL DOWNLOADS 'RW060701
' 'RW060701
59920 SUB COLORDIR (STRNG$,FMS.DIR$) STATIC 'RW060701
IF GR < 2 THEN _
EXIT SUB
IF FMS.DIR$ = "N" THEN _
GOTO 59921
'
' INSERT COLOR FOR FILENAME
'
ON INSTR("\ *",LEFT$(STRNG$,1)) GOTO 59924,59922,59923
59921 STRNG$ = DR.1$ + LEFT$(STRNG$,13) + DR.2$ + MID$(STRNG$,14,10) + _
DR.3$ + MID$(STRNG$,24,10) + DR.4$ + MID$(STRNG$,34,MAX.DESC.LEN)
EXIT SUB
59922 STRNG$ = DR.4$ + STRNG$
EXIT SUB
59923 STRNG$ = EMPHASIZE.OFF$ + STRNG$
59924 END SUB
' $SUBTITLE: 'CHKCOLOR - subroutine to highlight based on search string'
' $PAGE
'
' SUBROUTINE NAME -- CHKCOLOR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' LOOK.FOR$ String that triggers highlight
' LOOK.IN$ String being searched
' END.COLOR$ Terminating color
'
' OUTPUT PARAMETERS -- STRNG$ Revised string
'
' SUBROUTINE PURPOSE -- Adds highlighting to a string within a string.
' Respects previous colorization.
SUB CHKCOLOR (LOOK.IN$,LOOK.FOR$,PASSED.END.COLOR$) STATIC
IF LOOK.FOR$ = "" THEN _
EXIT SUB
X$ = LOOK.IN$
CALL ALLCAPS (X$)
START.COLOR = INSTR(X$,LOOK.FOR$)
IF START.COLOR < 1 THEN _
EXIT SUB
END.COLOR$ = PASSED.END.COLOR$
IF END.COLOR$ = "" THEN _
END.COLOR$ = EMPHASIZE.OFF$ : _
CALL FINDLAST (LEFT$(LOOK.IN$,START.COLOR-1),ESCAPE$,WHERE.FOUND,J) : _
IF WHERE.FOUND > 0 THEN _
J = INSTR(WHERE.FOUND,LOOK.IN$,"m") : _
IF J > 0 THEN _
END.COLOR$ = MID$(LOOK.IN$,WHERE.FOUND,J-WHERE.FOUND+1)
CALL BRACKET (LOOK.IN$,START.COLOR,START.COLOR + LEN(LOOK.FOR$)-1,EMPHASIZE.ON$,END.COLOR$)
' CALL COLORIZE (LOOK.IN$,START.COLOR + LEN(LOOK.FOR$) - 1,START.COLOR,EMPHASIZE.ON$,END.COLOR$)
END SUB
' $SUBTITLE: 'SETHILITE - subroutine to reset highlight preference'
' $PAGE
'
' SUBROUTINE NAME -- SETHILITE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SET.TO New value (True or False)
' EMPHASIZE.ON.DEF$ String turns emphasize on
' EMPHASIZE.OFF.DEF$ String turns emphasize off
'
' OUTPUT PARAMETERS -- HIGHLIGHT.OFF Callers preference on Hilite
' EMPHASIZE.ON$ String to use for emphasis
' EMPHASIZE.OFF$ String to use after emphasis
'
SUB SETHILITE (SET.TO) STATIC
HIGHLIGHT.OFF = (EMPHASIZE.ON.DEF$ <> "" AND SET.TO)
IF HIGHLIGHT.OFF THEN _
EMPHASIZE.ON$ = "" : _
EMPHASIZE.OFF$ = "" : _
FG.1$ = "" : _
FG.2$ = "" : _
FG.3$ = "" : _
FG.4$ = "" _
ELSE EMPHASIZE.ON$ = EMPHASIZE.ON.DEF$ : _
FG.1$ = FG.1.DEF$ : _
FG.2$ = FG.2.DEF$ : _
FG.3$ = FG.3.DEF$ : _
FG.4$ = FG.4.DEF$
END SUB
' $SUBTITLE: 'COLORPMT - subroutine to colorize prompts'
' $PAGE
'
' SUBROUTINE NAME -- COLORPMT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ String to colorize
' HIGHLIGHT.OFF Whether highlighting is off
' EMPHASIZE.ON$ String to use for emphasis
' EMPHASIZE.OFF$ String to use after emphasis
'
' OUTPUT PARAMETERS -- STRNG$ Colorized string
'
' SUBROUTINE PURPOSE -- colorizes a string based on sysop settings
' and the string.
' [...] is the default - put in emphasis
' <...> options to type - put in FG.4$
' and first two precedign words use FG.1$ and FG.2$
' options identified on right by ) and on
' left by space or comma - put in FG.4$
'
SUB COLORPMT (STRNG$) STATIC
IF HIGHLIGHT.OFF THEN _
EXIT SUB
ALREADY.COLORIZED = (INSTR(STRNG$,ESCAPE$) > 0)
X = INSTR(STRNG$,"<")
IF X > 0 THEN _
GOTO 59943
X = INSTR(STRNG$,"[") ' highlight default
IF X > 0 THEN _
Y = INSTR(X,STRNG$,"]") : _
IF Y > 0 THEN _
CALL BRACKET (STRNG$,X,Y,EMPHASIZE.ON$,EMPHASIZE.OFF$)
IF ALREADY.COLORIZED THEN _
EXIT SUB
X = INSTR(STRNG$,"<")
IF X < 1 THEN _
GOTO 59945
59943 Y = INSTR(X,STRNG$,">")
IF Y < 1 THEN _
GOTO 59945
CALL BRACKET (STRNG$,X,Y,FG.4$,EMPHASIZE.OFF$)
Y = INSTR(STRNG$," ")
IF Y > 1 AND Y < X THEN _
STRNG$ = FG.1$ + STRNG$ : _
Z = INSTR(Y+1,STRNG$," ") : _
IF Z > 1 AND Z < X+LEN(FG.1$) THEN _
STRNG$ = LEFT$(STRNG$,Z) + FG.2.DEF$ + MID$(STRNG$,Z+1)
EXIT SUB
59945 X = 1
DID.INSERT = FALSE
L = LEN(FG.4$)
59950 Y = INSTR (X,STRNG$,")") ' x: where command begins, y: terminating pos
Z = INSTR (X,STRNG$,",")
IF Y = 0 OR (Z > 0 AND Z < Y) THEN _
Y = Z
K = LEN(STRNG$)
IF X > K THEN _
EXIT SUB
IF Y < 1 THEN _
IF NOT DID.INSERT THEN _
EXIT SUB _
ELSE Y = K+1
Z = Y - 1
WHILE Z > 0 ' got terminating pos: find beginning
IF INSTR(OPTION.END$,MID$(STRNG$,Z,1)) > 0 THEN _
X = Z + 1 : _
Z = 0
Z = Z - 1
WEND
IF Y-X < 3 THEN _ ' exclude commands too long
CMND.STRNG$ = MID$(STRNG$,X,Y-X) : _
X$ = CMND.STRNG$ : _
CALL ALLCAPS (CMND.STRNG$) : _
IF X$ = CMND.STRNG$ THEN _ ' exclude lower case
DID.INSERT = TRUE : _
CALL BRACKET (STRNG$,X,Y-1,FG.4$,EMPHASIZE.OFF$) : _ ' colorize
Y = Y + L
X = Y + 1
GOTO 59950
END SUB
' $SUBTITLE: 'BRACKET - Inserts strings around a string'
' $PAGE
'
' SUBROUTINE NAME -- BRACKET
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ Insert in this string
' B4.HERE Insert 1st before this pos
' AFTER.HERE Insert 2nd after this pos
' B4.STRNG$ String to insert before
' AFTER.STRNG$ String to insert after
'
' OUTPUT PARAMETERS -- STRNG$
'
' SUBROUTINE PURPOSE -- Primarily for colorization
'
SUB BRACKET (STRNG$,B4.HERE,AFTER.HERE,B4.STRNG$,AFTER.STRNG$) STATIC
STRNG$ = LEFT$(STRNG$,B4.HERE-1) + _
B4.STRNG$ + _
MID$(STRNG$,B4.HERE,AFTER.HERE-B4.HERE+1) + _
AFTER.STRNG$ + _
RIGHT$(STRNG$,LEN(STRNG$) - AFTER.HERE)
END SUB
' $SUBTITLE: 'USERCOLOR - lets user set color for normal text'
' $PAGE
'
' SUBROUTINE NAME -- USERCOLOR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' EMPHASIZE.OFF$ Normal text color
'
' OUTPUT PARAMETERS -- EMPHASIZE.OFF$ New text color
' BOLD.TEXT$ Whether bold (0 not, 1 bold)
' USER.TEXT.COLOR ANSI Color selected
'
' SUBROUTINE PURPOSE -- Lets caller select desired color and whether
' bold.
SUB USERCOLOR STATIC
IF HIGHLIGHT.OFF THEN _
EXIT SUB
59970 CALL QTPUT (EMPHASIZE.OFF$,0)
A$ = "Make text R)ed,G)reen,Y)ellow,B)lue,P)urple,C)yan,W)hite" + PRESS.ENTER.EXPERT$
GOSUB 59973
IF Q = 0 THEN _
EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" : _
EXIT SUB
CALL ALLCAPS (B$)
X = INSTR("RGYBPCW",B$)
IF X = 0 THEN _
GOTO 59970
USER.TEXT.COLOR = 30 + X
A$ = "Make text BOLD (Y,[N])"
GOSUB 59973
BOLD.TEXT$ = CHR$(48 - YES)
EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
GOTO 59970
59973 SUBROUTINE.PARAMETER = 1
TURBO.KEY = -TURBO.KEY.USER
CALL TGET
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
RETURN
END SUB
' $SUBTITLE: 'SETUGD - Sets user graphic preference'
' $PAGE
'
' SUBROUTINE NAME -- SETUGD
'
' INPUT PARAMETERS -- PARAMETER MEANING
' GRAPHICS.NUMBER 0=None, 1=Ascii, 2=color
'
' OUTPUT PARAMETERS -- GR Shared var - set to
' graphics.number
' GRAPHICS.LETTER$ What add to file name to
' see if got graphics file ver
'
' SUBROUTINE PURPOSE -- Sets file graphics preference
'
SUB SETUGD (GRAPHICS.NUMBER,GRAPHICS.LETTER$) STATIC
GR = GRAPHICS.NUMBER
IF GR = 2 THEN _
DR.1$ = FG.1.DEF$ : _
DR.2$ = FG.2.DEF$ : _
DR.3$ = FG.3.DEF$ : _
DR.4$ = FG.4.DEF$ _
ELSE DR.1$ = "" : _
DR.2$ = "" : _
DR.3$ = "" : _
DR.4$ = ""
GRAPHICS.LETTER$ = MID$(" GC",GR+1, - (GR > 0))
END SUB
' $SUBTITLE: 'EOFCOMM - Determines whether input in comm port buffer'
' $PAGE
'
' SUBROUTINE NAME -- EOFCOMM
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FOSSIL Whether fossil driver used
' COMPORT% Comm port # in use
'
' OUTPUT PARAMETERS -- NOCHARS% -1 (TRUE) if no chars in buffer.
' Anything else means has char.
'
' SUBROUTINE PURPOSE -- Query comm port to see if input waiting
'
60000 SUB EOFCOMM (NOCHARS%) STATIC
IF FOSSIL THEN _
CALL FOSREADAHEAD(COMPORT%,NOCHARS%) _
ELSE NOCHARS% = EOF(3)
END SUB
' $SUBTITLE: 'GSANDR - Global search and replace'
' $PAGE
'
' SUBROUTINE NAME -- GSANDR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ String to edit
' LOOK.FOR$ String to look for
' REPLACE.BY$ String to replace by
'
' OUTPUT PARAMETERS -- STRNG$ Edited string
'
' SUBROUTINE PURPOSE -- Replaces every occurence of LOOK.FOR$ that
' is in STRNG$ by REPLACE.BY$
'
60100 SUB GSANDR (STRNG$,LOOK.FOR$,REPLACE.BY$) STATIC
IF LOOK.FOR$ = "" THEN _
EXIT SUB
X = 1
L = LEN(REPLACE.BY$)
M = LEN(LOOK.FOR$)
60102 Y = INSTR(X,STRNG$,LOOK.FOR$)
IF Y < 1 THEN _
EXIT SUB
STRNG$ = LEFT$(STRNG$,Y-1) + _
REPLACE.BY$ + _
RIGHT$(STRNG$,LEN(STRNG$)-Y+1-M)
X = Y + L
IF X > LEN(STRNG$) THEN _
EXIT SUB
GOTO 60102
END SUB
' $SUBTITLE: 'METAGSR -- Meta Global search and replace'
' $PAGE
'
' SUBROUTINE NAME -- METAGSR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ String to edit
'
' OUTPUT PARAMETERS -- STRNG$ Edited string
'
' SUBROUTINE PURPOSE -- Sets up the file transfer META statements
'
SUB METAGSR (STRNG$) STATIC
IF BATCH.TRANSFER THEN _
CALL GSANDR (STRNG$,"[FILE]","@"+NODE.WORK.FILE$) _
ELSE CALL GSANDR (STRNG$,"[FILE]",FILE.NAME$)
CALL GSANDR (STRNG$,"[BAUD]",TALK.TO.MODEM.AT$)
CALL GSANDR (STRNG$,"[PORT]",COM.PORT$)
CALL GSANDR (STRNG$,"[PORT#]",MID$(COM.PORT$,4))
CALL GSANDR (STRNG$,"[PARITY]",MID$(BAUD.PARITY$,INSTR(BAUD.PARITY$,",")+1,1))
CALL GSANDR (STRNG$,"[PROTO]",FT$)
CALL GSANDR (STRNG$,"[NODE]",NODE.ID$)
I = 1
X$ = "[1]"
WHILE INSTR(STRNG$,X$) > 0
CALL GSANDR (STRNG$,X$,A$(I))
I = I + 1
X$ = "["+MID$(STR$(I),2)+"]"
WEND
END SUB
' $SUBTITLE: 'TIMELOCK - Test TIME LOCK for premium features'
' $PAGE
'
' SUBROUTINE NAME -- TIMELOCK (written by Doug Azzarito)
'
' INPUT PARAMETERS -- PARAMETER MEANING
' TIME.LOCK.SET SECONDS/SESSION TO LOCK
'
' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER -1 if feature is LOCKED
'
' SUBROUTINE PURPOSE -- Check elapsed time for lock duration
'
60150 SUB TIMELOCK STATIC
CALL TIMEREMAIN(TIME.REMAINING!)
IF TCA! > TIME.LOCK.SET THEN _
OK = TRUE : _
EXIT SUB
CALL BUFFILE(HELP.PATH$+"TIMELOCK"+HELP.EXTENSION$,X)
IF NOT OK THEN _
CALL QTPUT("Sorry, " + FIRST.NAME$ + _
", function unavailable for first" + _
STR$(TIME.LOCK.SET) + "seconds",1)
OK = FALSE
END SUB
' $PAGE
'
' SUBROUTINE NAME -- MARKTIME
'
' INPUT PARAMETERS -- PARAMETER MEANING
' DOT.NUMBER How many dots printed
'
' OUTPUT PARAMETERS -- DOT.NUMBER
'
' SUBROUTINE PURPOSE -- Marks time by putting colorized dots out
' to 4, then erasing
'
60200 SUB MARKTIME (DOT.NUMBER) STATIC
CALL FINDTIME (TI!)
IF TI! - PREV.TI! < 1.0 THEN _
EXIT SUB
PREV.TI! = TI!
IF REMOVE.DOT AND DOT.NUMBER > 0 THEN _
CALL QTPUT (BACKSPACE$,0) : _
DOT.NUMBER = DOT.NUMBER - 1 : _
EXIT SUB
DOT.NUMBER = DOT.NUMBER + 1
ON DOT.NUMBER GOTO 60201,60202,60203,60204
60201 X$ = FG.1$
REMOVE.DOT = FALSE
GOTO 60205
60202 X$ = FG.2$
GOTO 60205
60203 X$ = FG.3$
GOTO 60205
60204 X$ = FG.4$
REMOVE.DOT = TRUE
60205 CALL QTPUT (X$ + "." + EMPHASIZE.OFF$,0)
END SUB
' $SUBTITLE: 'AUTOPAGE - NOTIFIES SYSOP WHEN SPECIFIC USER CALLS'
' $PAGE
'
' SUBROUTINE NAME -- AUTOPAGE 'Contributed by Gregg and Bob Snyder
' 'and RoseMarie Siddiqui
'
' INPUT PARAMETERS -- AUTOPAGE.DEF$ List of conditions that trigger
' notification and how
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- Search AUTOPAGE.DEF$ for match on whether
' on name, security level, whether new user.
' Also controls whether caller notified and
' number of times sysop has bell rung.
' And what tune to play (if any).
'
60300 SUB AUTOPAGE STATIC
CALL FINDIT (AUTOPAGE.DEF$)
IF NOT OK THEN _
EXIT SUB
EC = 0
OK = FALSE
WHILE NOT EOF(2) AND OK = FALSE AND EC = 0
CALL READPARMS (WORK.ARA$(),4,1)
IF EC = 0 THEN _
OK = (WORK.ARA$(1) = ACTIVE.USER.NAME$) : _
IF NOT OK THEN _
IF NEW.USER AND WORK.ARA$(1) = "NEWUSER" THEN _
OK = TRUE _
ELSE IF LEFT$(WORK.ARA$(1),1) = "/" AND LEN(WORK.ARA$(1)) > 2 THEN _
B = INSTR (2,WORK.ARA$(1),"/") : _
IF B > 0 AND LEN(WORK.ARA$(1)) > B THEN _
IF USER.SECURITY.LEVEL <= VAL(MID$(WORK.ARA$(1),B+1)) AND _
USER.SECURITY.LEVEL >= VAL(MID$(WORK.ARA$(1),2)) THEN _
OK = TRUE
WEND
CLOSE 2
IF NOT OK THEN _
EXIT SUB
PAGE.STATUS$ = "AutoPaged!"
IF LEFT$(WORK.ARA$(2),1) = "N" THEN _
A$ = "Sysop asked to be notified of your presence" : _
CALL RINGCALLER
B = (WORK.ARA$(4) = "")
WORK.ARA$(5) = ""
FOR I = 1 TO VAL(WORK.ARA$(3))
IF B THEN _
CALL PSCRN (BELL.RINGER$) _
ELSE WORK.ARA$(5) = WORK.ARA$(5) + "O4 X" + VARPTR$(WORK.ARA$(4))
NEXT
IF NOT B THEN _
PLAY WORK.ARA$(5)
END SUB
' $SUBTITLE: 'PUTMATTR - subroutine to save msg. attributes'
' $PAGE
'
' SUBROUTINE NAME -- PUTMATTR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' Q
' B$
' LINES.IN.MESSAGE
' S
' NON.STOP
' MESSAGE.DIM.INDEX
'
' OUTPUT PARAMETERS -- SQ
' LG$(10)
' LINES.IN.MESSAGE.SAVE
' SL
' NON.STOP.SAVE
' MESSAGE.DIM.INDEX.SAVE
'
' SUBROUTINE PURPOSE -- WHEN REPLYING TO A MESSAGE THIS ROUTINE SAVES
' THE ATTRIBUTES OF THE ORGINAL MESSAGE
'
62520 SUB PUTMATTR STATIC
SQ = Q
LG$(10) = B$
LINES.IN.MESSAGE.SAVE = LINES.IN.MESSAGE
SL = S
NON.STOP.SAVE = NON.STOP
MESSAGE.DIM.INDEX.SAVE = MESSAGE.DIM.INDEX
END SUB
' $SUBTITLE: 'GETMATTR - subroutine to get msg. attributes'
' $PAGE
'
' SUBROUTINE NAME -- GETMATTR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SQ
' LG$(10)
' LINES.IN.MESSAGE.SAVE
' SL
' NON.STOP.SAVE
' MESSAGE.DIM.INDEX.SAVE
'
' OUTPUT PARAMETERS -- Q
' B$
' LINES.IN.MESSAGESAVE
' S
' NON.STOP
' MESSAGE.DIM.INDEX
' KILL.MESSAGE
'
' SUBROUTINE PURPOSE -- AFTER REPLYING TO A MESSAGE THIS ROUTINE RESTORES
' THE ATTRIBUTES OF THE ORGINAL MESSAGE
'
62530 SUB GETMATTR STATIC
Q = SQ
B$ = LG$(10)
LINES.IN.MESSAGE = LINES.IN.MESSAGE.SAVE
S = SL
NON.STOP = NON.STOP.SAVE
MESSAGE.DIM.INDEX = MESSAGE.DIM.INDEX.SAVE
KILL.MESSAGE = FALSE
END SUB
' $SUBTITLE: 'RPTTIME -- Reports time on system'
' $PAGE
'
' SUBROUTINE NAME -- RPTTIME
'
' INPUT PARAMETERS -- PARAMETER MEANING
'
' OUTPUT PARAMETERS --
'
' SUBROUTINE PURPOSE -- Tells user time used on system
'
SUB RPTTIME STATIC
CALL SKIPLINE (1)
CALL GETIME
SUBROUTINE.PARAMETER = 2
CALL AMORPM
QX = ((HHH * 60) + MMM + (SSS / 60.0)) * 10.0
Q! = QX / 10.0
MINS = (HHH * 60) + MMM
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
CALL QTPUT("Now: " + DATE$ + " at " + TIME$,1)
CALL QTPUT("On for" + STR$(MINS) + " mins," + STR$(SSS) + " secs",1)
END SUB
' $SUBTITLE: 'PROTOCOL - Determine protocols available'
' $PAGE
'
' SUBROUTINE NAME -- PROTOCOL
'
' INPUT PARAMETERS -- PARAMETER MEANING
' PROTO.DEF$ File of installed protocols
'
' OUTPUT PARAMETERS -- TRANSFER.OPTIONS$ Prompt for protocol choice
' DFLTXFER$ Letters of protocols
' INTERNAL.EQUIV$ Internal protocol to use
'
' SUBROUTINE PURPOSE -- TO determine what protocols are available to user
'
SUB PROTOCOL STATIC
62600 CALL FINDIT (PROTO.DEF$)
IF NOT OK THEN _
TRANSFER.OPTIONS$ = "A)scii,X)modem,C)rcXmodem,Y)modem" : _
INTERNAL.EQUIV$ = "AXCY" : _
DFLTXFER$ = "AXCY" : _
GOTO 62604
DFLTXFER$ = ""
INTERNAL.EQUIV$ = ""
TRANSFER.OPTIONS$ = ""
L = 0
62602 IF EOF(2) THEN _
GOTO 62604
CALL READPARMS (WORK.ARA$(),13,1)
IF EC > 0 THEN _
EXIT SUB
DFLTXFER$ = DFLTXFER$ + " "
INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + " "
IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _
GOTO 62602
IF LEFT$(WORK.ARA$(5),1) = "R" THEN _
IF NOT RELIABLE.MODE THEN _
GOTO 62602
IF LEFT$(WORK.ARA$(3),1) = "I" THEN _
GOTO 62603
X = INSTR(WORK.ARA$(12)+" "," ")
X$ = LEFT$(WORK.ARA$(12),X-1)
CALL FINDFILE (X$,FOUND)
IF FOUND THEN _
X = INSTR(WORK.ARA$(13)+" "," ") : _
X$ = LEFT$(WORK.ARA$(13),X-1) : _
CALL FINDFILE (X$,FOUND)
IF NOT FOUND THEN _
GOTO 62602
62603 MID$(DFLTXFER$,LEN(DFLTXFER$),1) = LEFT$(WORK.ARA$(1),1)
CALL FINDLAST (WORK.ARA$(1),CRLF$,X,I)
IF X > 0 AND X >= LEN(WORK.ARA$(1)) - 2 THEN _
WORK.ARA$(1) = LEFT$(WORK.ARA$(1),X-1)
IF (L + LEN(WORK.ARA$(1)) < 62) AND X = 0 THEN _
TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + "," + WORK.ARA$(1) : _
L = L + LEN(WORK.ARA$(1)) + 1 _
ELSE L = LEN(WORK.ARA$(1)) : _
TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + _
CRLF$ + _
WORK.ARA$(1)
IF LEFT$(WORK.ARA$(3),1) = "I" AND RIGHT$(WORK.ARA$(3),1) <> "I" THEN _
MID$(INTERNAL.EQUIV$,LEN(INTERNAL.EQUIV$),1) = RIGHT$(WORK.ARA$(3),1)
GOTO 62602
62604 IF INSTR(INTERNAL.EQUIV$,"N") > 0 THEN _
GOTO 62605
IF X = 0 THEN _
TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + ",N)one" _
ELSE TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + CRLF$ + "N)one"
DFLTXFER$ = DFLTXFER$ + "N"
INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + "N"
62605 IF LEFT$(TRANSFER.OPTIONS$,1) = "," THEN _
TRANSFER.OPTIONS$ = MID$(TRANSFER.OPTIONS$,2)
IF INSTR(DFLTXFER$,USER.TRANSFER.DEFAULT$) = 0 THEN _
CALL QTPUT ("Protocol "+USER.TRANSFER.DEFAULT$+" unavailable. Default reset to None",1) : _
USER.TRANSFER.DEFAULT$ = MID$(DFLTXFER$,INSTR(INTERNAL.EQUIV$,"N"),1)
END SUB
' $SUBTITLE: 'TRANSFER - subroutine for KERMIT, YMODEM, IMODEM & YMODEM'
' $PAGE
'
' SUBROUTINE NAME -- TRANSFER
'
' INPUT PARAMETERS -- PARAMETER MEANING
' TRANSFER.FUNCTION = 1 DOWNLOAD FILE TO USER
' = 2 UPLOAD FILE TO RBBS-PC
' FILE.NAME$ NAME OF FILE FOR TRANSFER
' COM.PORT$ NAME OF COMMUNICATIONS PORT
' TO BE USED BY KERMIT (COM1
' OR COM2)
' BPS = -1 FOR 300 BAUD
' = -2 FOR 450 BAUD
' = -3 FOR 1200 BAUD
' = -4 FOR 2400 BAUD
' = -5 FOR 4800 BAUD
' = -6 FOR 9600 BAUD
' = -7 FOR 19200 BAUD
' PCKERMIT.EXE.FILE$ FILE TO TRANSFER CONTROL TO
' FOR KERMIT PROTOCOL ON
' PROTOCOL.PATH$.
' QMXFER.COM.FILE$ FILE TO TRANSFER CONTROL TO
' FOR YMODEM, IMODEM OR
' YMODEMG PROTOCOLS.
' WXMODEM.COM.FILE$ FILE TO TRANSFER CONTROL TO
' FOR WXMODEM PROTOCOL ON
' PROTOCOL.PATH$
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- TO TRANSFER FILES USING KERMIT, YMODEM, IMODEM,
' YMODEMG OR WXMODEM PROTOCOL'S
'
62620 SUB TRANSFER STATIC
IF PRIVATE.DOOR THEN _
CALL XFRETURN : _
EXIT SUB
IF TRANSFER.FUNCTION = 1 THEN _
B$ = DOWN.TEMPLATE$ : _
Z$ = "send " _
ELSE IF TRANSFER.FUNCTION = 2 THEN _
B$ = UP.TEMPLATE$ : _
Z$ = "receive "
CALL METAGSR (B$)
CALL QTPUT ("Protocol: "+PROTO.PROMPT$,1)
CALL QTPUT ("Ready to " + Z$ + " ",0)
IF BATCH.TRANSFER THEN _
CALL QTPUT ("(BATCH)",1) : _
CALL OPENWORK (NODE.WORK.FILE$) : _
WHILE NOT EOF(2) : _
CALL READANY : _
CALL BRKFNAME (A$,Z$,Y$,X$,TRUE) : _
CALL QTPUT (" "+Y$+X$,1) : _
WEND _
ELSE CALL QTPUT (FILE.NAME.HOLD$,1)
CALL XFRETURN
END SUB
' $SUBTITLE: 'XFRETURN - subroutine to exit as a private door.'
' $PAGE
'
' SUBROUTINE NAME -- XFRETURN
'
' INPUT PARAMETERS -- PARAMETER MEANING
' TRANSFER.FUNCTION = 1 DOWNLOAD FILE TO USER
' = 2 UPLOAD FILE TO RBBS-PC
' = 3 USER REGISTRATION PGM
' B$ NAME OF FILE TO EXIT TO
' COM.PORT$ NAME OF COMMUNICATIONS PORT
' TO BE USED BY KERMIT (COM1
' OR COM2)
' BPS = -1 FOR 300 BAUD
' = -2 FOR 450 BAUD
' = -3 FOR 1200 BAUD
' = -4 FOR 2400 BAUD
' = -5 FOR 4800 BAUD
' = -6 FOR 9600 BAUD
' = -7 FOR 19200 BAUD
' QMXFER.COM.FILE$ FILE TO TRANSFER CONTROL TO
' FOR YMODEM, IMODEM OR
' YMODEMG PROTOCOLS.
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- TO TRANSFER CONTROL TO ANOTHER PROGRAM
'
SUB XFRETURN STATIC
IF PRIVATE.DOOR THEN _
GOTO 62630
IF FAKE.XRPT THEN _
CALL FAKEXRPT (FT$)
IF ADVANCE.PROTO.WRITE THEN _
CALL OPENOUTW ("XFER-"+NODE.ID$+".DEF") : _
IF EC < 1 THEN _
CALL PRNTWRKA (FILE.NAME$+",,"+FT$) : _
CLOSE 2
IF PROTO.METHOD$ = "S" THEN _
GOTO 62629
62628 X$ = LEFT$(B$,INSTR(B$+" "," ")-1)
IF X$ = "" THEN _
EXIT SUB
CALL FINDIT (X$)
IF NOT OK THEN _
A$ = "Missing door program" : _
CALL UPDTCALR (A$ + " " + X$,1) : _
SNOOP = TRUE : _
CALL LPRNT (A$,1) : _
EXIT SUB
A$(1) = DISK.FOR.DOS$ + _
"COMMAND /C " + _
B$
A$(2) = RBBS.BAT$
PRIVATE.DOOR = TRUE
CALL QTPUT ("Exiting to External Program for File Tranfer",1)
'IF TRANSFER.FUNCTION < 3 THEN _
' X$ = "File Tranfer. Please begin..." _
'ELSE X$ = "Registration"
'CALL QTPUT (X$,1)
LOCATE 25,1
CALL LPRNT(LINE.FEED$,0)
CALL RBBSEXIT (A$(),2)
62629 CALL DELAYIT (8 + BPS)
IF FOSSIL THEN _
CALL FOSEXIT(COMPORT%) _
ELSE CLOSE 3 : _
OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1
SHELL B$
IF FOSSIL THEN _
CALL FOSINIT(COMPORT%,RESULT%) : _
IF RESULT% = -1 THEN _
CALL PSCRN("ERROR INITIALIZING FOSSIL AFTER EXTERNAL PROTOCOL") : _
SYSTEM
CALL DELAYIT (2)
62630 PARITY$ = MID$(",N,8,1,E,7,1",7 + 6 * EIGHT.BIT,6)
IF LOCAL.USER THEN _
GOTO 62631
IF FOSSIL THEN _
CALL SETBAUD _
ELSE CALL OPENCOM(TALK.TO.MODEM.AT$,PARITY$)
IF PRIVATE.DOOR THEN _
CALL DELAYIT (7 + BPS) : _
CALL QTPUT ("Reloading RBBS-PC. Please be patient.",1)
62631 CALL SKIPLINE (2)
LOCATE 24,1
62632 END SUB
' $SUBTITLE: 'FAKEXRPT - subroutine to create fake xfer report'
' $PAGE
'
' SUBROUTINE NAME -- FAKEXRPT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILE.NAME.HOLD$ FILE TO BE TRANSFERRED
' PROTO.USED$ PROTOCOL USED
'
' OUTPUT PARAMETERS -- WRITES OUT TRANSFER FILE REPORT
'
' SUBROUTINE PURPOSE -- EXTERNAL PROTOCOL DRIVERS THAT DO NOT WRITE
' OUT A STANDARD TRANSFER REPORT MUST HAVE ONE
' PROVIDED IN ORDER FOR "DOORING" TO EXTERNAL
' PROTOCOLS TO WORK PROPERLY, SINCE THIS FILE
' IS READ UPON RETURNING FROM AN EXTERNAL PROTOCOL.
'
62650 SUB FAKEXRPT (PROTO.USED$) STATIC
CLOSE 2
OPEN "O",2,"XFER-" + _
NODE.FILE.ID$ + _
".DEF"
PRINT #2,FILE.NAME$
PRINT #2,
PRINT #2,PROTO.USED$
PRINT #2,"S"
CLOSE 2
END SUB
' $SUBTITLE: 'SETEXPERT - subroutine to adjust for expert change'
' $PAGE
'
' SUBROUTINE NAME -- SETEXPERT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' EXPERT.USER WHETHER IS AN EXPERT
'
' OUTPUT PARAMETERS -- MORE.PROMPT$ Pause prompt
' PRESS.ENTER$ Prompt to press enter
'
' SUBROUTINE PURPOSE -- EXTERNAL PROTOCOL DRIVERS THAT DO NOT WRITE
' OUT A STANDARD TRANSFER REPORT MUST HAVE ONE
' PROVIDED IN ORDER FOR "DOORING" TO EXTERNAL
' PROTOCOLS TO WORK PROPERLY, SINCE THIS FILE
' IS READ UPON RETURNING FROM AN EXTERNAL PROTOCOL.
'
62660 SUB SETEXPERT STATIC
IF EXPERT.USER THEN _
MORE.PROMPT$ = "More <[Y],N,C,A" : _
PRESS.ENTER$ = PRESS.ENTER.EXPERT$ : _
EXIT SUB
MORE.PROMPT$ = "More [Y]es,N)o,C)ontinuous,A)bort"
PRESS.ENTER$ = PRESS.ENTER.NOVICE$
END SUB
' $SUBTITLE: 'TIMEDOUT - subroutine to exit based on time of day'
' $PAGE
'
' SUBROUTINE NAME -- TIMEDOUT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' RCTTY.BAT$
' NODE.RECORD.INDEX
' MESSAGE.RECORD$
' MODEM.INIT.BAUD$
' MODEM.GO.OFFHOOK.COMMADN$
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- WHEN RBBS-PC IS TO EXIT TO DOS AT A SPECIFIC TIME OF
' DAY, THIS ROUTINE WRITES OUT TO THE FILE SPECIFIED
' IN "RCTTY.BAT$" THE ONE-LINE ENTRY:
' RBBSTIMx.BAT
' WHERE "x" IS EQUAL TO THE NODE ID.
'
63000 SUB TIMEDOUT STATIC
FIELD #1,128 AS MESSAGE.RECORD$
SUBROUTINE.PARAMETER = 3
CALL FILELOCK
GET 1,NODE.RECORD.INDEX
X$ = DATE$
CALL CSTRDATE (X$,Y$)
MID$(MESSAGE.RECORD$,77,2) = Y$
MID$(MESSAGE.RECORD$,86,5) = LEFT$(TIME$,5)
PUT 1,NODE.RECORD.INDEX
SUBROUTINE.PARAMETER = 2
CALL FILELOCK
CLOSE 2
CALL BRKFNAME(CALLERS.FILE$,X$,Y$,Z$,TRUE)
FILE.NAME$ = X$ + "RBBS" + NODE.FILE.ID$ + "TM.DEF"
OPEN "O",2,FILE.NAME$
PRINT #2,MID$(FILE.NAME$,3,7)
CLOSE 2
IF LOCAL.USER.MODE THEN _
EXIT SUB
IF SUBROUTINE.PARAMETER <> 7 THEN _
SUBROUTINE.PARAMETER = 4 : _
CALL FILELOCK : _
CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1")
CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$)
IF MULTI.LINK.PRESENT <> 0 THEN _
CALL DELAYIT (3)
END SUB
' $SUBTITLE: 'ASKUSERS - subroutine to get registration information'
' $PAGE
'
' SUBROUTINE NAME -- ASKUSERS (WRITTEN BY JON MARTIN)
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILE.NAME$ NAME OF THE FILE CONTAINING THE
' SCRIPT TO BE USED WHEN ASKING
' THE USER QUESTIONS.
' ACTIVE.USER.NAME$ NAME OF THE CURRENT USER
' USER.SECURITY.LEVEL USER'S SECURITY
' UPPER.CASE SET IF USER NEEDS UPPERCASE
'
' OUTPUT PARAMETERS -- WRITE THE USER'S RESPONSES TO THE QUESTIONS TO THE
' FILE NAME SPECIFIED AS THE FIRST PARAMETER IN THE
' FIRST RECORD OF THE FILE CONTAINING THE SCRIPT TO
' BE USED.
' USER.SECURITY.LEVEL CAN BE RAISED OR LOWERED
'
' SUBROUTINE PURPOSE -- PROVIDES A SOPHISTCATED, SCRIPT DRIVEN MECHANISM BY
' WHICH A SYSOP CAN SOLICIT INFORMATION FROM NEW USERS
' (VIA A SCRIPT THAT REQUESTS REGISTRATION INFORMATION
' AND WHICH CAN UPPER OR LOWER HIS DEFAULT SECURITY
' LEVEL BASED ON THE RESPONSES) OR ASK A QUESTIONS OF
' WHEN THE USER LOGS OFF. THE FORMER OCCURS IF THE
' FILE "RBBS-REG.DEF" CONTAINING THE REGISTRATION
' SCRIPT EXISTS ON THE SAME DRIVE AS THE "WELCOME".
' THE LATER EXISTS IF THE FILE "EPILOG.DEF" EXISTS ON
' THE SAME DRIVE AS THE "WELCOME".
'
SUB ASKUSERS STATIC
'
' *
' * LOAD SCRIPT CONTAING THE QUESTIONS INTO THE A$ DIMENSION *
' *
'
64005 CHAT.AVAILABLE = FALSE
QUESTIONNAIRE.CHAIN = FALSE
CALL OPENWORK (FILE.NAME$)
INPUT #2,APPEND.FILE.NAME$,MAXIMUM.SECURITY.LEVEL
'
' *
' * THE FIRST RECORD OF THE SCRIPT FILE CONTAINS TWO PARAMETERS: *
' * 1. THE NAME OF THE FILE TO APPEND THE ANSWERS TO. *
' * 2. THE MAXIMUM SECURITY LEVEL THE + COMMAND CAN RAISE A USER SECURITY *
' *
SCRIPT.INDEX = 1
A$(SCRIPT.INDEX) = ACTIVE.USER.NAME$ + _
" " + _
DATE$ + _
" " + _
TIME$
64010 IF EOF(2) OR SCRIPT.INDEX > 255 THEN _
GOTO 64100
SCRIPT.INDEX = SCRIPT.INDEX + 1
LINE INPUT #2,A$(SCRIPT.INDEX)
IF UPPER.CASE THEN _
CALL ALLCAPS (A$(SCRIPT.INDEX))
IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _
SCRIPT.INDEX = SCRIPT.INDEX + 1 : _
A$(SCRIPT.INDEX) = "!"
GOTO 64010
'
' *
' * PROCESS QUESTIONS IN THE SCRIPT AS FOLLOWS: *
' * *
' * FIRST COLUMN MEANING *
' * : THIS LINE IS A LABEL THAT MAY BE BRANCHED TO *
' * ! THIS MEANS THIS IS AN ANSWER *
' * > THIS IS A "GOTO" COMMAND TO ONE OF THE LABELS *
' * * THIS MEANS THE LINE IS A MESSAGE TO BE WRITTEN TO THE USER *
' * ? THIS MEANS THIS IS A QUESTION FOR THE USER *
' * = THIS MEANS THAT THIS LINE CONTAINS DECISION CRITERIA *
' * - THIS MEANS TO LOWER THE USER'S SECURITY LEVEL *
' * + THIS MEANS TO RAISE THE USER'S SECURITY LEVEL *
' * @ THIS MEANS TO ABORT THE QUESTIONNAIRE DO NOT WRITE OUT *
' * & THIS MEANS TO CHAIN TO ANOTHER QUESTIONNAIRE *
' *
'
64100 SCRIPT.MAX = SCRIPT.INDEX
SCRIPT.INDEX = 1
64110 CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64115
SCRIPT.INDEX = SCRIPT.INDEX + 1
IF SCRIPT.INDEX > SCRIPT.MAX THEN _
GOTO 64400
IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _ ' LABEL
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _ ' ANSWER
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "@" THEN _ ' ABORT
QUESTIONNAIRE.ABORTED = TRUE : _
GOTO 64510
IF LEFT$(A$(SCRIPT.INDEX),1) = ">" THEN _ ' GOTO
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),2) : _
GOSUB 64200 : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "*" THEN _ ' MESSAGE
A$ = MID$(A$(SCRIPT.INDEX),2) : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE GOTO 64110
64113 IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _ ' QUESTION
A$ = MID$(A$(SCRIPT.INDEX),2) : _
SUBROUTINE.PARAMETER = 1 : _
CALL TGET : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE IF Q = 0 THEN _
GOTO 64113 _
ELSE A$(SCRIPT.INDEX + 1) = "!" + _
B$ : _
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),2) = "=#" THEN _ ' NUMERIC
GOSUB 64350 : _
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "=" THEN _ ' DECISION
GOSUB 64300 : _
IF SUBROUTINE.PARAMETER = -1 THEN _
GOTO 64510 _
ELSE GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "-" THEN _ ' LOWER
ADJUSTED.SECURITY = -1 : _
USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - _
VAL(MID$(A$(SCRIPT.INDEX),2,5)) : _
USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _ ' RAISE
IF USER.SECURITY.LEVEL + VAL(MID$(A$(SCRIPT.INDEX),2,5)) _
<= MAXIMUM.SECURITY.LEVEL THEN _
ADJUSTED.SECURITY = -1 : _
USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _
USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + _
VAL(MID$(A$(SCRIPT.INDEX),2,5))
IF LEFT$(A$(SCRIPT.INDEX),1) = "+" THEN _
GOTO 64110
IF LEFT$(A$(SCRIPT.INDEX),1) = "&" THEN _
QUESTIONNAIRE.CHAIN = TRUE : _
FILE.NAME.HOLD$ = MID$(A$(SCRIPT.INDEX),2) : _
GOTO 64110
A$ = "Invalid line. Column 1 is <" + LEFT$(A$(SCRIPT.INDEX),1)+">. Must be: * ? = + - > @ &"
SUBROUTINE.PARAMETER = 5
CALL TPUT
64115 GOTO 64510
'
' *
' * SEARCH FOR GOTO LABEL *
' *
'
64200 SCRIPT.INDEX = 1
64210 SCRIPT.INDEX = SCRIPT.INDEX + 1
IF SCRIPT.INDEX > SCRIPT.MAX THEN _
A$ = BRANCH.LABEL$ + _
" not found!" : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
IF SUBROUTINE.PARAMETER = -1 THEN _
RETURN _
ELSE GOTO 64115
IF LEFT$(A$(SCRIPT.INDEX),1) <> ":" THEN _
GOTO 64210
IF MID$(A$(SCRIPT.INDEX),2) <> BRANCH.LABEL$ THEN _
GOTO 64210
RETURN
'
' *
' * DETERMINE BRANCH LOGIC *
' *
'
64300 CURRENT.EQUALS = 1
Z$ = RIGHT$(A$(SCRIPT.INDEX - 1),1)
CALL ALLCAPS (Z$)
64310 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
IF NEXT.EQUALS = 0 THEN _
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
GOTO 64320
IF Z$ <> _
MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 1,1) THEN _
CURRENT.EQUALS = NEXT.EQUALS : _
GOTO 64310
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
64320 GOSUB 64200
RETURN
'
' *
' * DETERMINE NUMERIC BRANCH LOGIC *
' *
'
64350 CURRENT.EQUALS = 1
64360 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
IF NEXT.EQUALS = 0 THEN _
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
GOTO 64380
NUMERIC = TRUE
LOOP.INDEX = 2
WHILE LOOP.INDEX < LEN(A$(SCRIPT.INDEX - 1)) +1
IF INSTR("()1234567890- ",MID$(A$(SCRIPT.INDEX - 1),LOOP.INDEX,1)) THEN _
GOTO 64370
NUMERIC = FALSE
64370 LOOP.INDEX = LOOP.INDEX + 1
WEND
IF NOT NUMERIC THEN _
CURRENT.EQUALS = NEXT.EQUALS : _
GOTO 64360
BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
64380 GOSUB 64200
RETURN
'
' *
' * WRITE RESPONSES TO DESIGNATED FILE *
' *
'
64400 SCRIPT.INDEX = 0
EC = 0
SUBROUTINE.PARAMETER = 9
FILE.NAME$ = APPEND.FILE.NAME$
EN$ = APPEND.FILE.NAME$
CALL FILELOCK
CALL OPENWRKA (APPEND.FILE.NAME$)
IF EC <> 0 THEN _
A$ = "Fatal Error in script!" : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
GOTO 64500
64410 SCRIPT.INDEX = SCRIPT.INDEX + 1
IF SCRIPT.INDEX > SCRIPT.MAX THEN _
GOTO 64500
IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
QUESTION.SAVE$ = MID$(A$(SCRIPT.INDEX),2) : _
GOTO 64410
IF LEFT$(A$(SCRIPT.INDEX),1) = "!" AND _
LEN(A$(SCRIPT.INDEX)) < 2 THEN _
GOTO 64410
IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _
CALL PRNTWRKA (QUESTION.SAVE$) : _
CALL PRNTWRKA (MID$(A$(SCRIPT.INDEX),2))
IF SCRIPT.INDEX = 1 AND _
NOT QUESTIONNAIRE.CHAIN.STARTED THEN _
CALL PRNTWRKA (A$(SCRIPT.INDEX))
IF EC <> 0 THEN _
A$ = "Unrecoverable failure in script!" : _
SUBROUTINE.PARAMETER = 5 : _
CALL TPUT : _
GOTO 64500
GOTO 64410
64500 CLOSE 2
SUBROUTINE.PARAMETER = 10
CALL FILELOCK
CALL CARRIER
IF QUESTIONNAIRE.CHAIN THEN _
QUESTIONNAIRE.CHAIN.STARTED = TRUE : _
FILE.NAME$ = FILE.NAME.HOLD$ : _
GOTO 64005
64510 CHAT.AVAILABLE = (INSTR("MUF",ACTIVE.MENU$) > 0)
END SUB
' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents'
' $PAGE
'
' SUBROUTINE NAME -- VIEWARC (Written by Jon Martin)
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILE.NAME$ NAME OF THE ARC FILE TO BE
' VIEWED.
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- PROVIDES A MECHANISM TO PROVIDE USERS WITH THE
' CONTENTS OF AN ARC FILE PRIOR TO DOWNLOADING.
SUB VIEWARC STATIC
64600 IF TURBO.RBBS THEN _
RETCODE% = 0 : _
CALL ARCV (ARC.WORK$,FILE.NAME$,RETCODE%) : _
CALL BUFFILE (ARC.WORK$,X) : _
EXIT SUB
CLOSE 2
OPEN "R",2,FILE.NAME$,1
FIELD 2,1 AS CHAR$
BYTE.POINTER! = 1
ARC.END! = LOF(2)
64605 IF BYTE.POINTER! > ARC.END! THEN _
GOTO 64620
GET 2,BYTE.POINTER!
IF CHAR$ <> CHR$(26) THEN _
GOTO 64620
BYTE.POINTER! = BYTE.POINTER! + 1
GET 2,BYTE.POINTER!
IF CHAR$ = CHR$(0) THEN _
GOTO 64620
ARCED.NAME$ = ""
FOR X = 1 TO 12
GET 2,BYTE.POINTER! + X
IF CHAR$ < CHR$(40) THEN _
GOTO 64610
ARCED.NAME$ = ARCED.NAME$ + _
CHAR$
NEXT
64610 A$ = ARCED.NAME$
BYTE.POINTER! = BYTE.POINTER! + 14
GOSUB 64630
TOTAL.BYTES# = WORK.BYTES#
BYTE.POINTER! = BYTE.POINTER! + 10
GOSUB 64630
FINAL.BYTES# = WORK.BYTES#
A$ = A$ + _
SPACE$(20 - LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) + _
STR$(FINAL.BYTES#) + _
" bytes."
CALL QTPUT(A$,1)
BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4
GOTO 64605
64620 CLOSE 2
SUBROUTINE.PARAMETER = 0
CALL CARRIER
A$ = ""
EXIT SUB
64630 FACTOR# = 1#
WORK.BYTES# = 0
FOR X = 0 TO 3
GET 2,BYTE.POINTER! + X
WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$)
FACTOR# = FACTOR# * 256#
NEXT
RETURN
END SUB